Source file registerer.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
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
module Source = struct
let hash =
Some (Tezos_crypto.Hashed.Protocol_hash.of_b58check_exn "PtMumbai2TmsJHNGRkD8v8YDbtao7BLUC3wjASn1inAKLFCjaH1")
let sources = Tezos_base.Protocol.
{ expected_env = V8 ;
components = [{ name = "Misc" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** {2 Helper functions} *)\n\nmodule Public_key_map : Map.S with type key = Signature.Public_key.t\n\ntype 'a lazyt = unit -> 'a\n\ntype 'a lazy_list_t = LCons of 'a * 'a lazy_list_t tzresult Lwt.t lazyt\n\ntype 'a lazy_list = 'a lazy_list_t tzresult Lwt.t\n\n(** Include bounds *)\nval ( --> ) : int -> int -> int list\n\nval ( <-- ) : int -> int -> int list\n\nval ( ---> ) : Int32.t -> Int32.t -> Int32.t list\n\nval pp_print_paragraph : Format.formatter -> string -> unit\n\nval take : int -> 'a list -> ('a list * 'a list) option\n\n(** Some (input with [prefix] removed), if string has [prefix], else [None] *)\nval remove_prefix : prefix:string -> string -> string option\n\n(** [remove nb list] remove the first [nb] elements from the list [list]. *)\nval remove_elem_from_list : int -> 'a list -> 'a list\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule Public_key_map = Map.Make (Signature.Public_key)\n\ntype 'a lazyt = unit -> 'a\n\ntype 'a lazy_list_t = LCons of 'a * 'a lazy_list_t tzresult Lwt.t lazyt\n\ntype 'a lazy_list = 'a lazy_list_t tzresult Lwt.t\n\nlet rec ( --> ) i j =\n (* [i; i+1; ...; j] *)\n if Compare.Int.(i > j) then [] else i :: (succ i --> j)\n\nlet rec ( <-- ) i j =\n (* [j; j-1; ...; i] *)\n if Compare.Int.(i > j) then [] else j :: (i <-- pred j)\n\nlet rec ( ---> ) i j =\n (* [i; i+1; ...; j] *)\n if Compare.Int32.(i > j) then [] else i :: (Int32.succ i ---> j)\n\nlet split delim ?(limit = max_int) path =\n let l = String.length path in\n let rec do_slashes acc limit i =\n if Compare.Int.(i >= l) then List.rev acc\n else if Compare.Char.(path.[i] = delim) then do_slashes acc limit (i + 1)\n else do_split acc limit i\n and do_split acc limit i =\n if Compare.Int.(limit <= 0) then\n if Compare.Int.(i = l) then List.rev acc\n else List.rev (String.sub path i (l - i) :: acc)\n else do_component acc (pred limit) i i\n and do_component acc limit i j =\n if Compare.Int.(j >= l) then\n if Compare.Int.(i = j) then List.rev acc\n else List.rev (String.sub path i (j - i) :: acc)\n else if Compare.Char.(path.[j] = delim) then\n do_slashes (String.sub path i (j - i) :: acc) limit j\n else do_component acc limit i (j + 1)\n in\n if Compare.Int.(limit > 0) then do_slashes [] limit 0 else [path]\n\nlet pp_print_paragraph ppf description =\n Format.fprintf\n ppf\n \"@[%a@]\"\n Format.(pp_print_list ~pp_sep:pp_print_space pp_print_string)\n (split ' ' description)\n\nlet take n l =\n let rec loop acc n xs =\n if Compare.Int.(n <= 0) then Some (List.rev acc, xs)\n else match xs with [] -> None | x :: xs -> loop (x :: acc) (n - 1) xs\n in\n loop [] n l\n\nlet remove_prefix ~prefix s =\n let x = String.length prefix in\n let n = String.length s in\n if Compare.Int.(n >= x) && Compare.String.(String.sub s 0 x = prefix) then\n Some (String.sub s x (n - x))\n else None\n\nlet rec remove_elem_from_list nb = function\n | [] -> []\n | _ :: _ as l when Compare.Int.(nb <= 0) -> l\n | _ :: tl -> remove_elem_from_list (nb - 1) tl\n" ;
} ;
{ name = "Non_empty_string" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** A string that is guaranteed to be non-empty *)\ntype t = private string\n\ninclude Compare.S with type t := t\n\n(** Returns [None] if the original string is empty. *)\nval of_string : string -> t option\n\n(** Fails with [Invalid_argument] if the original string is empty. *)\nval of_string_exn : string -> t\n\n(** [cat2 a b] concatenates [a] and [b].\n [cat2 a ~sep b] concatenates [a], [sep], and [b]. *)\nval cat2 : t -> ?sep:string -> t -> t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ninclude Compare.String\n\nlet of_string = function \"\" -> None | s -> Some s\n\nlet of_string_exn = function\n | \"\" -> invalid_arg \"Unexpected empty string\"\n | s -> s\n\nlet cat2 a ?(sep = \"\") b = String.concat sep [a; b]\n" ;
} ;
{ name = "Path_encoding" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021 DaiLambda, Inc. <contact@dailambda.jp> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule type S = sig\n type t\n\n (** [to_path t postfix] returns the context path name for [t]\n postfixed with [postfix] *)\n val to_path : t -> string list -> string list\n\n (** [of_path path] parses [path] as a context path name for [t] *)\n val of_path : string list -> t option\n\n (** Directory levels of the path encoding of [t] *)\n val path_length : int\nend\n\nmodule type ENCODING = sig\n type t\n\n val to_bytes : t -> bytes\n\n val of_bytes_opt : bytes -> t option\nend\n\n(** Path encoding in hex: [/[0-9a-f]{2}+/] *)\nmodule Make_hex (H : ENCODING) : S with type t := H.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021 DaiLambda, Inc. <contact@dailambda.jp> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule type S = sig\n type t\n\n val to_path : t -> string list -> string list\n\n val of_path : string list -> t option\n\n val path_length : int\nend\n\nmodule type ENCODING = sig\n type t\n\n val to_bytes : t -> bytes\n\n val of_bytes_opt : bytes -> t option\nend\n\nmodule Make_hex (H : ENCODING) = struct\n let path_length = 1\n\n let to_path t l =\n let (`Hex key) = Hex.of_bytes (H.to_bytes t) in\n key :: l\n\n let of_path = function\n | [path] -> Option.bind (Hex.to_bytes (`Hex path)) H.of_bytes_opt\n | _ -> None\nend\n" ;
} ;
{ name = "Storage_description" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module is responsible for building the description of the current state\n of the storage, which is then used to build specification of the RPC\n endpoints for accessing the storage. It produces [resto] [RPC_directory.t]\n values, which can be used directly to construct the RPC endpoint tree. *)\n\n(** Typed description of the key-value context. *)\ntype 'key t\n\n(** Trivial display of the key-value context layout. *)\nval pp : Format.formatter -> 'key t -> unit\n\n(** Export an RPC hierarchy for querying the context. There is one service\n by possible path in the context. Services for \"directory\" are able to\n aggregate in one JSON object the whole subtree. *)\nval build_directory : 'key t -> 'key RPC_directory.t\n\n(** Create a empty context description,\n keys will be registered by side effects. *)\nval create : unit -> 'key t\n\n(** Register a single key accessor at a given path. *)\nval register_value :\n 'key t -> get:('key -> 'a option tzresult Lwt.t) -> 'a Data_encoding.t -> unit\n\n(** Return a description for a prefixed fragment of the given context.\n All keys registered in the subcontext will be shared by the external\n context *)\nval register_named_subcontext : 'key t -> string list -> 'key t\n\n(** Description of an index as a sequence of `RPC_arg.t`. *)\ntype (_, _, _) args =\n | One : {\n rpc_arg : 'a RPC_arg.t;\n encoding : 'a Data_encoding.t;\n compare : 'a -> 'a -> int;\n }\n -> ('key, 'a, 'key * 'a) args\n | Pair :\n ('key, 'a, 'inter_key) args * ('inter_key, 'b, 'sub_key) args\n -> ('key, 'a * 'b, 'sub_key) args\n\n(** Return a description for a indexed sub-context.\n All keys registered in the subcontext will be shared by the external\n context. One should provide a function to list all the registered\n index in the context. *)\nval register_indexed_subcontext :\n 'key t ->\n list:('key -> 'arg list tzresult Lwt.t) ->\n ('key, 'arg, 'sub_key) args ->\n 'sub_key t\n\n(** Helpers for manipulating and defining indexes. *)\n\nval pack : ('key, 'a, 'sub_key) args -> 'key -> 'a -> 'sub_key\n\nval unpack : ('key, 'a, 'sub_key) args -> 'sub_key -> 'key * 'a\n\nmodule type INDEX = sig\n type t\n\n include Path_encoding.S with type t := t\n\n val rpc_arg : t RPC_arg.t\n\n val encoding : t Data_encoding.t\n\n val compare : t -> t -> int\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule StringMap = Map.Make (String)\n\ntype 'key t = 'key desc_with_path\n\n(** [desc_with_path] describes a position in the storage. It's composed\n [rev_path] which is the reverse path up to the position, and [dir] the\n position's [description]. [rev_path] is only useful in case of an error to\n print a descriptive message. [List.rev rev_path] is a storage's path that\n contains no conflict and allows the registration of a [dir]'s storage.\n NB: [rev_path] indicates the position in the tree, so once the node is\n added, it won't change; whereas [dir] is mutable because when more subtrees\n are added this may require updating it. *)\nand 'key desc_with_path = {\n rev_path : string list;\n mutable dir : 'key description;\n}\n\nand 'key description =\n | Empty : 'key description\n | Value : {\n get : 'key -> 'a option tzresult Lwt.t;\n encoding : 'a Data_encoding.t;\n }\n -> 'key description\n | NamedDir : 'key t StringMap.t -> 'key description\n | IndexedDir : {\n arg : 'a RPC_arg.t;\n arg_encoding : 'a Data_encoding.t;\n list : 'key -> 'a list tzresult Lwt.t;\n subdir : ('key * 'a) t;\n }\n -> 'key description\n\nlet rec pp : type a. Format.formatter -> a t -> unit =\n fun ppf {dir; _} ->\n match dir with\n | Empty -> Format.fprintf ppf \"Empty\"\n | Value _e -> Format.fprintf ppf \"Value\"\n | NamedDir map ->\n Format.fprintf\n ppf\n \"@[<v>%a@]\"\n (Format.pp_print_list pp_item)\n (StringMap.bindings map)\n | IndexedDir {arg; subdir; _} ->\n let name = Format.asprintf \"<%s>\" (RPC_arg.descr arg).name in\n pp_item ppf (name, subdir)\n\nand pp_item : type a. Format.formatter -> string * a t -> unit =\n fun ppf (name, desc) -> Format.fprintf ppf \"@[<hv 2>%s@ %a@]\" name pp desc\n\nlet pp_rev_path ppf path =\n Format.fprintf\n ppf\n \"[%a]\"\n Format.(\n pp_print_list\n ~pp_sep:(fun ppf () -> pp_print_string ppf \" / \")\n pp_print_string)\n (List.rev path)\n\nlet rec register_named_subcontext : type r. r t -> string list -> r t =\n fun desc names ->\n match (desc.dir, names) with\n | _, [] -> desc\n | Value _, _ | IndexedDir _, _ ->\n Format.kasprintf\n invalid_arg\n \"Could not register a named subcontext at %a because of an existing %a.\"\n pp_rev_path\n desc.rev_path\n pp\n desc\n | Empty, name :: names ->\n let subdir = {rev_path = name :: desc.rev_path; dir = Empty} in\n desc.dir <- NamedDir (StringMap.singleton name subdir) ;\n register_named_subcontext subdir names\n | NamedDir map, name :: names ->\n let subdir =\n match StringMap.find name map with\n | Some subdir -> subdir\n | None ->\n let subdir = {rev_path = name :: desc.rev_path; dir = Empty} in\n desc.dir <- NamedDir (StringMap.add name subdir map) ;\n subdir\n in\n register_named_subcontext subdir names\n\ntype (_, _, _) args =\n | One : {\n rpc_arg : 'a RPC_arg.t;\n encoding : 'a Data_encoding.t;\n compare : 'a -> 'a -> int;\n }\n -> ('key, 'a, 'key * 'a) args\n | Pair :\n ('key, 'a, 'inter_key) args * ('inter_key, 'b, 'sub_key) args\n -> ('key, 'a * 'b, 'sub_key) args\n\nlet rec unpack : type a b c. (a, b, c) args -> c -> a * b = function\n | One _ -> fun x -> x\n | Pair (l, r) ->\n let unpack_l = unpack l in\n let unpack_r = unpack r in\n fun x ->\n let c, d = unpack_r x in\n let b, a = unpack_l c in\n (b, (a, d))\n\nlet rec pack : type a b c. (a, b, c) args -> a -> b -> c = function\n | One _ -> fun b a -> (b, a)\n | Pair (l, r) ->\n let pack_l = pack l in\n let pack_r = pack r in\n fun b (a, d) ->\n let c = pack_l b a in\n pack_r c d\n\nlet rec compare : type a b c. (a, b, c) args -> b -> b -> int = function\n | One {compare; _} -> compare\n | Pair (l, r) -> (\n let compare_l = compare l in\n let compare_r = compare r in\n fun (a1, b1) (a2, b2) ->\n match compare_l a1 a2 with 0 -> compare_r b1 b2 | x -> x)\n\nlet destutter equal l =\n match l with\n | [] -> []\n | (i, _) :: l ->\n let rec loop acc i = function\n | [] -> acc\n | (j, _) :: l -> if equal i j then loop acc i l else loop (j :: acc) j l\n in\n loop [i] i l\n\nlet rec register_indexed_subcontext :\n type r a b.\n r t -> list:(r -> a list tzresult Lwt.t) -> (r, a, b) args -> b t =\n fun desc ~list path ->\n match path with\n | Pair (left, right) ->\n let compare_left = compare left in\n let equal_left x y = Compare.Int.(compare_left x y = 0) in\n let list_left r = list r >|=? fun l -> destutter equal_left l in\n let list_right r =\n let a, k = unpack left r in\n list a >|=? fun l ->\n List.map snd (List.filter (fun (x, _) -> equal_left x k) l)\n in\n register_indexed_subcontext\n (register_indexed_subcontext desc ~list:list_left left)\n ~list:list_right\n right\n | One {rpc_arg = arg; encoding = arg_encoding; _} -> (\n match desc.dir with\n | Value _ | NamedDir _ ->\n Format.kasprintf\n invalid_arg\n \"Could not register an indexed subcontext at %a because of an \\\n existing %a.\"\n pp_rev_path\n desc.rev_path\n pp\n desc\n | Empty ->\n let subdir =\n {\n rev_path =\n Format.sprintf \"(Maybe of %s)\" RPC_arg.(descr arg).name\n :: desc.rev_path;\n dir = Empty;\n }\n in\n desc.dir <- IndexedDir {arg; arg_encoding; list; subdir} ;\n subdir\n | IndexedDir {arg = inner_arg; subdir; _} -> (\n match RPC_arg.eq arg inner_arg with\n | None ->\n Format.kasprintf\n invalid_arg\n \"An indexed subcontext at %a already exists but has a \\\n different argument: `%s` <> `%s`.\"\n pp_rev_path\n desc.rev_path\n (RPC_arg.descr arg).name\n (RPC_arg.descr inner_arg).name\n | Some RPC_arg.Eq -> subdir))\n\nlet register_value :\n type a b.\n a t -> get:(a -> b option tzresult Lwt.t) -> b Data_encoding.t -> unit =\n fun desc ~get encoding ->\n match desc.dir with\n | Empty -> desc.dir <- Value {get; encoding}\n | _ ->\n Format.kasprintf\n invalid_arg\n \"Could not register a value at %a because of an existing %a.\"\n pp_rev_path\n desc.rev_path\n pp\n desc\n\nlet create () = {rev_path = []; dir = Empty}\n\nmodule type INDEX = sig\n type t\n\n include Path_encoding.S with type t := t\n\n val rpc_arg : t RPC_arg.t\n\n val encoding : t Data_encoding.t\n\n val compare : t -> t -> int\nend\n\ntype _ handler =\n | Handler : {\n encoding : 'a Data_encoding.t;\n get : 'key -> int -> 'a tzresult Lwt.t;\n }\n -> 'key handler\n\ntype _ opt_handler =\n | Opt_handler : {\n encoding : 'a Data_encoding.t;\n get : 'key -> int -> 'a option tzresult Lwt.t;\n }\n -> 'key opt_handler\n\nlet rec combine_object = function\n | [] ->\n Handler {encoding = Data_encoding.unit; get = (fun _ _ -> return_unit)}\n | (name, Opt_handler handler) :: fields ->\n let (Handler handlers) = combine_object fields in\n Handler\n {\n encoding =\n Data_encoding.merge_objs\n Data_encoding.(obj1 (opt name (dynamic_size handler.encoding)))\n handlers.encoding;\n get =\n (fun k i ->\n handler.get k i >>=? fun v1 ->\n handlers.get k i >|=? fun v2 -> (v1, v2));\n }\n\ntype query = {depth : int}\n\nlet depth_query =\n let open RPC_query in\n query (fun depth -> {depth})\n |+ field \"depth\" RPC_arg.uint 0 (fun t -> t.depth)\n |> seal\n\nlet build_directory : type key. key t -> key RPC_directory.t =\n fun dir ->\n let rpc_dir = ref (RPC_directory.empty : key RPC_directory.t) in\n let register :\n type ikey.\n chunked:bool -> (key, ikey) RPC_path.t -> ikey opt_handler -> unit =\n fun ~chunked path (Opt_handler {encoding; get}) ->\n let service =\n RPC_service.get_service ~query:depth_query ~output:encoding path\n in\n rpc_dir :=\n RPC_directory.opt_register ~chunked !rpc_dir service (fun k q () ->\n get k (q.depth + 1))\n in\n let rec build_handler :\n type ikey. ikey t -> (key, ikey) RPC_path.t -> ikey opt_handler =\n fun desc path ->\n match desc.dir with\n | Empty ->\n Opt_handler\n {encoding = Data_encoding.unit; get = (fun _ _ -> return_none)}\n | Value {get; encoding} ->\n let handler =\n Opt_handler\n {\n encoding;\n get =\n (fun k i -> if Compare.Int.(i < 0) then return_none else get k);\n }\n in\n register ~chunked:true path handler ;\n handler\n | NamedDir map ->\n let fields = StringMap.bindings map in\n let fields =\n List.map\n (fun (name, dir) ->\n (name, build_handler dir RPC_path.(path / name)))\n fields\n in\n let (Handler handler) = combine_object fields in\n let handler =\n Opt_handler\n {\n encoding = handler.encoding;\n get =\n (fun k i ->\n if Compare.Int.(i < 0) then return_none\n else handler.get k (i - 1) >>=? fun v -> return_some v);\n }\n in\n register ~chunked:true path handler ;\n handler\n | IndexedDir {arg; arg_encoding; list; subdir} ->\n let (Opt_handler handler) =\n build_handler subdir RPC_path.(path /: arg)\n in\n let encoding =\n let open Data_encoding in\n union\n [\n case\n (Tag 0)\n ~title:\"Leaf\"\n (dynamic_size arg_encoding)\n (function key, None -> Some key | _ -> None)\n (fun key -> (key, None));\n case\n (Tag 1)\n ~title:\"Dir\"\n (tup2\n (dynamic_size arg_encoding)\n (dynamic_size handler.encoding))\n (function key, Some value -> Some (key, value) | _ -> None)\n (fun (key, value) -> (key, Some value));\n ]\n in\n let get k i =\n if Compare.Int.(i < 0) then return_none\n else if Compare.Int.(i = 0) then return_some []\n else\n list k >>=? fun keys ->\n List.map_es\n (fun key ->\n if Compare.Int.(i = 1) then return (key, None)\n else handler.get (k, key) (i - 1) >|=? fun value -> (key, value))\n keys\n >>=? fun values -> return_some values\n in\n let handler =\n Opt_handler\n {encoding = Data_encoding.(list (dynamic_size encoding)); get}\n in\n register ~chunked:true path handler ;\n handler\n in\n ignore (build_handler dir RPC_path.open_root : key opt_handler) ;\n !rpc_dir\n" ;
} ;
{ name = "State_hash" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020-2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** A specialized Blake2B implementation for hashing internal states of random\n number generators. *)\n\ninclude S.HASH\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nlet random_state_hash = \"\\076\\064\\204\" (* rng(53): never used... *)\n\nmodule H =\n Blake2B.Make\n (Base58)\n (struct\n let name = \"random\"\n\n let title = \"A random generation state\"\n\n let b58check_prefix = random_state_hash\n\n let size = None\n end)\n\ninclude H\ninclude Path_encoding.Make_hex (H)\n\nlet () = Base58.check_encoded_prefix b58check_encoding \"rng\" 53\n" ;
} ;
{ name = "Nonce_hash" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020-2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** A specialized Blake2B implementation for hashing nonces. *)\n\ninclude S.HASH\n\ninclude Path_encoding.S with type t := t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(* 32 *)\nlet nonce_hash = \"\\069\\220\\169\" (* nce(53) *)\n\nmodule H =\n Blake2B.Make\n (Base58)\n (struct\n let name = \"cycle_nonce\"\n\n let title = \"A nonce hash\"\n\n let b58check_prefix = nonce_hash\n\n let size = None\n end)\n\ninclude H\ninclude Path_encoding.Make_hex (H)\n\nlet () = Base58.check_encoded_prefix b58check_encoding \"nce\" 53\n" ;
} ;
{ name = "Script_expr_hash" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020-2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** A specialized Blake2B implementation for hashing Michelson expressions. *)\n\ninclude S.HASH\n\ninclude Path_encoding.S with type t := t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nlet script_expr_hash = \"\\013\\044\\064\\027\" (* expr(54) *)\n\nmodule H =\n Blake2B.Make\n (Base58)\n (struct\n let name = \"script_expr\"\n\n let title = \"A script expression ID\"\n\n let b58check_prefix = script_expr_hash\n\n let size = None\n end)\n\ninclude H\ninclude Path_encoding.Make_hex (H)\n\nlet () = Base58.check_encoded_prefix b58check_encoding \"expr\" 54\n" ;
} ;
{ name = "Origination_nonce" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Originated contracts and tx rollups handles are crafted from the hash of the\n operation that triggered their origination (and nothing else). As a single\n operation can trigger several originations, the corresponding handles are\n forged from a deterministic sequence of nonces, initialized with the hash of\n the operation. *)\ntype t = {operation_hash : Operation_hash.t; origination_index : int32}\n\nval encoding : t Data_encoding.t\n\nval initial : Operation_hash.t -> t\n\nval incr : t -> t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t = {operation_hash : Operation_hash.t; origination_index : int32}\n\nlet encoding =\n let open Data_encoding in\n conv\n (fun {operation_hash; origination_index} ->\n (operation_hash, origination_index))\n (fun (operation_hash, origination_index) ->\n {operation_hash; origination_index})\n @@ obj2 (req \"operation\" Operation_hash.encoding) (dft \"index\" int32 0l)\n\nlet initial operation_hash = {operation_hash; origination_index = 0l}\n\nlet incr nonce =\n let origination_index = Int32.succ nonce.origination_index in\n {nonce with origination_index}\n" ;
} ;
{ name = "Contract_hash" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020-2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** A specialized Blake2B implementation for hashing contract identifiers. *)\n\ninclude S.HASH\n\n(** [of_nonce nonce] is the contract address originated from [nonce]. *)\nval of_nonce : Origination_nonce.t -> t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(* 20 *)\nlet contract_hash = \"\\002\\090\\121\" (* KT1(36) *)\n\nmodule H =\n Blake2B.Make\n (Base58)\n (struct\n let name = \"Contract_hash\"\n\n let title = \"A contract ID\"\n\n let b58check_prefix = contract_hash\n\n let size = Some 20\n end)\n\ninclude H\ninclude Path_encoding.Make_hex (H)\n\nlet () = Base58.check_encoded_prefix b58check_encoding \"KT1\" 36\n\nlet of_nonce nonce =\n let data =\n Data_encoding.Binary.to_bytes_exn Origination_nonce.encoding nonce\n in\n hash_bytes [data]\n" ;
} ;
{ name = "Blinded_public_key_hash" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module handles hashes of implicit contract addresses used for\n commitments in the origin block.\n\n This module is needed because for legal reasons, when the blockchain is\n activated, the btz1 addresses of participants to the fundraising are not\n listed directly but instead their hashes are listed, together with their\n balances. Thus, the listed accounts can be activated and credited in the\n activation block. *)\n\ninclude S.HASH\n\ntype activation_code\n\nval activation_code_encoding : activation_code Data_encoding.t\n\nval of_ed25519_pkh : activation_code -> Ed25519.Public_key_hash.t -> t\n\nval activation_code_of_hex : string -> activation_code option\n\nmodule Index : Storage_description.INDEX with type t = t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule H =\n Blake2B.Make\n (Base58)\n (struct\n let name = \"Blinded public key hash\"\n\n let title = \"A blinded public key hash\"\n\n let b58check_prefix = \"\\001\\002\\049\\223\"\n\n let size = Some Ed25519.Public_key_hash.size\n end)\n\nmodule Index : Storage_description.INDEX with type t = H.t = struct\n include H\n include Path_encoding.Make_hex (H)\nend\n\ninclude H\n\nlet () = Base58.check_encoded_prefix b58check_encoding \"btz1\" 37\n\nlet of_ed25519_pkh activation_code pkh =\n hash_bytes ~key:activation_code [Ed25519.Public_key_hash.to_bytes pkh]\n\ntype activation_code = bytes\n\nlet activation_code_size = Ed25519.Public_key_hash.size\n\nlet activation_code_encoding =\n Data_encoding.Fixed.(bytes Hex) activation_code_size\n\nlet activation_code_of_hex h =\n if Compare.Int.(String.length h <> activation_code_size * 2) then None\n else Hex.to_bytes (`Hex h)\n" ;
} ;
{ name = "Block_payload_hash" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** A specialized Blake2B implementation for hashing block's payloads. *)\n\ninclude S.HASH\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2020 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(* 32 *)\nlet prefix = \"\\001\\106\\242\" (* vh(52) *)\n\ninclude\n Blake2B.Make\n (Base58)\n (struct\n let name = \"value_hash\"\n\n let title = \"Hash of a consensus value\"\n\n let b58check_prefix = prefix\n\n let size = None\n end)\n\nlet () = Base58.check_encoded_prefix b58check_encoding \"vh\" 52\n" ;
} ;
{ name = "Tx_rollup_prefixes" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t = {\n b58check_prefix : string;\n prefix : string;\n hash_size : int;\n b58check_size : int;\n}\n\n(** See {!Tx_rollup_repr}. *)\nval rollup_address : t\n\n(** See {!Tx_rollup_inbox_repr}. *)\nval inbox_hash : t\n\n(** See {!Tx_rollup_message_repr}. *)\nval message_hash : t\n\n(** See {!Tx_rollup_commitment_repr}. *)\nval commitment_hash : t\n\n(** See {!Tx_rollup_commitment_repr}. *)\nval message_result_hash : t\n\n(** See {!Tx_rollup_message_result_repr.Merkle}. *)\nval message_result_list_hash : t\n\n(** See {!Tx_rollup_withdraw_repr}. *)\nval withdraw_list_hash : t\n\n(** See {!Tx_rollup_inbox_repr.inbox_hash}. *)\nval inbox_list_hash : t\n\n(** [check_encoding spec encoding] checks that [encoding] satisfies\n [spec]. Raises an exception otherwise. *)\nval check_encoding : t -> 'a Base58.encoding -> unit\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t = {\n b58check_prefix : string;\n prefix : string;\n hash_size : int;\n b58check_size : int;\n}\n\nlet rollup_address =\n {\n b58check_prefix = \"\\001\\128\\120\\031\";\n prefix = \"txr1\";\n hash_size = 20;\n b58check_size = 37;\n }\n\nlet inbox_hash =\n {\n b58check_prefix = \"\\079\\148\\196\";\n prefix = \"txi\";\n hash_size = 32;\n b58check_size = 53;\n }\n\nlet inbox_list_hash = inbox_hash\n\nlet message_hash =\n {\n b58check_prefix = \"\\079\\149\\030\";\n prefix = \"txm\";\n hash_size = 32;\n b58check_size = 53;\n }\n\nlet commitment_hash =\n {\n b58check_prefix = \"\\079\\148\\017\";\n prefix = \"txc\";\n hash_size = 32;\n b58check_size = 53;\n }\n\nlet message_result_hash =\n {\n b58check_prefix = \"\\018\\007\\206\\087\";\n prefix = \"txmr\";\n hash_size = 32;\n b58check_size = 54;\n }\n\nlet message_result_list_hash =\n {\n b58check_prefix = \"\\079\\146\\082\";\n prefix = \"txM\";\n hash_size = 32;\n b58check_size = 53;\n }\n\nlet withdraw_list_hash =\n {\n b58check_prefix = \"\\079\\150\\072\";\n prefix = \"txw\";\n hash_size = 32;\n b58check_size = 53;\n }\n\nlet check_encoding {prefix; b58check_size; _} encoding =\n Base58.check_encoded_prefix encoding prefix b58check_size\n" ;
} ;
{ name = "Sc_rollup_reveal_hash" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** The type of a reveal hash. *)\ntype t\n\n(** The hashing schemes supported by the reveal hash. *)\ntype supported_hashes = Blake2B\n\n(** A Map module for storing reveal-hash-indexed values. *)\nmodule Map : Map.S with type key = t\n\n(** [size ~scheme] returns the size of reveal hashes using the [scheme]\n specified in input. *)\nval size : scheme:supported_hashes -> int\n\n(** [zero ~scheme] returns the reveal hash corresponding to the zero hash\n for the [scheme] specified in input. *)\nval zero : scheme:supported_hashes -> t\n\n(** Formatting function for reveal-hashes. *)\nval pp : Format.formatter -> t -> unit\n\n(** [equal hash1 hash2] checks if the two reveal-hashes [hash1] and [hash2]\n are equal. This function must preserve the equality of individual\n supported hashing schemes. If [hash1] and [hash2] are hashes obtained\n from the same supported hashing scheme, then the [equal] function from\n that hashing scheme is used to determine whether they are equivalent.\n Otherwise, they are different. *)\nval equal : t -> t -> bool\n\n(** [compare hash1 hash2] compares the values of the reveal hashes [hash1]\n and [hash2]. This function must preserve the ordering of individual\n supported hashing scheme. If [hash1] and [hash2] are reveal-hashes\n obtained from the same hashing scheme, then [compare hash1 hash2]\n should return the same result of the compare function exposed\n by the hash module corresponding to their hashing scheme. *)\nval compare : t -> t -> int\n\n(* [of_b58check_opt base58_hash] returns the reveal-hash, if any,\n whose base58 encoding is [base58_hash]. To avoid ambiguity,\n the [S.HASH] modules supported should avoid using the same prefix\n for the base58 encoding. *)\nval of_b58check_opt : string -> t option\n\n(* The encoding of reveal hashes. *)\nval encoding : t Data_encoding.t\n\n(* [hash_string ~scheme ?key strings] hashes [strings] using the\n supported hashing [scheme] given in input. *)\nval hash_string : scheme:supported_hashes -> ?key:string -> string list -> t\n\n(* [hash_bytes ~scheme ?key strings] hashes [bytes] using the\n supported hashing [scheme] given in input. *)\nval hash_bytes : scheme:supported_hashes -> ?key:bytes -> bytes list -> t\n\n(* [to_b58check hash] returns the base58 encoded reveal hash. *)\nval to_b58check : t -> string\n\n(* [scheme_of_hash] hash returns the supported hashing scheme\n that was used to obtain [hash]. *)\nval scheme_of_hash : t -> supported_hashes\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(* Reserve the first byte in the encoding to support multi-versioning\n in the future. *)\nmodule Blake2B = struct\n include\n Blake2B.Make\n (Base58)\n (struct\n let name = \"Smart_rollup_reveal_data_blake2b_hash\"\n\n let title = \"A smart rollup reveal hash\"\n\n let b58check_prefix =\n \"\\230\\206\\128\\200\\196\" (* \"scrrh1(56)\" decoded from Base58. *)\n\n let size = Some 32\n end)\n\n let () = Base58.check_encoded_prefix b58check_encoding \"scrrh1\" 56\nend\n\ntype supported_hashes = Blake2B\n\ntype t = Blake2B of Blake2B.t\n\nlet zero ~(scheme : supported_hashes) =\n match scheme with Blake2B -> Blake2B Blake2B.zero\n\nlet pp ppf hash = match hash with Blake2B hash -> Blake2B.pp ppf hash\n\nlet equal h1 h2 =\n match (h1, h2) with Blake2B h1, Blake2B h2 -> Blake2B.equal h1 h2\n\nlet compare h1 h2 =\n match (h1, h2) with Blake2B h1, Blake2B h2 -> Blake2B.compare h1 h2\n\nmodule Map = Map.Make (struct\n type tmp = t\n\n type t = tmp\n\n let compare = compare\nend)\n\nlet of_b58check_opt b58_hash =\n b58_hash |> Blake2B.of_b58check_opt |> Option.map (fun hash -> Blake2B hash)\n\n(* Size of the hash is the size of the inner hash plus one byte for the\n tag used to identify the hashing scheme. *)\nlet size ~(scheme : supported_hashes) =\n let tag_size = 1 in\n let size_without_tag = match scheme with Blake2B -> Blake2B.size in\n tag_size + size_without_tag\n\nlet encoding =\n let open Data_encoding in\n union\n ~tag_size:`Uint8\n [\n case\n ~title:\"Reveal_data_hash_v0\"\n (Tag 0)\n Blake2B.encoding\n (fun (Blake2B s) -> Some s)\n (fun s -> Blake2B s);\n ]\n\nlet hash_string ~(scheme : supported_hashes) ?key strings =\n match scheme with Blake2B -> Blake2B (Blake2B.hash_string ?key strings)\n\nlet hash_bytes ~(scheme : supported_hashes) ?key bytes =\n match scheme with Blake2B -> Blake2B (Blake2B.hash_bytes ?key bytes)\n\nlet to_b58check hash =\n match hash with Blake2B hash -> Blake2B.to_b58check hash\n\nlet scheme_of_hash hash =\n match hash with Blake2B _hash -> (Blake2B : supported_hashes)\n" ;
} ;
{ name = "Merkle_list" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error += Merkle_list_invalid_position\n\n(** Given a list of size [count_limit], returns the maximum depth of\n its merklisation. *)\nval max_depth : count_limit:int -> int\n\nmodule type T = sig\n (** The type of a Merkle list *)\n type t\n\n (** The type of a hash *)\n type h\n\n (** The type of an element *)\n type elt\n\n (** A path, together with an element's position, is the proof of inclusion\n of an element in the Merkle list. *)\n type path\n\n (** A dummy path that can be used as a placeholder when no path is\n actually required. *)\n val dummy_path : path\n\n val pp_path : Format.formatter -> path -> unit\n\n (** The empty Merkle list *)\n val nil : t\n\n (** The empty hash *)\n val empty : h\n\n (** [root t] returns the root hash of a Merkle list. *)\n val root : t -> h\n\n (** [snoc t el] adds element [el] to a Merkle list [t] and returns\n the new list. *)\n val snoc : t -> elt -> t\n\n (** Tail recursive variant of [snoc]. *)\n val snoc_tr : t -> elt -> t\n\n (** [compute elems] returns the root hash of the Merkle list constructed with\n [elems]. *)\n val compute : elt list -> h\n\n (** Encoding of a path. *)\n val path_encoding : path Data_encoding.t\n\n (** Encoding of a path, with optional bound [max_length]. *)\n val bounded_path_encoding : ?max_length:int -> unit -> path Data_encoding.t\n\n (** [compute_path t pos] computes the path of the element in position [pos].\n\n Can fail with [Merkle_list_invalid_position] if [pos] is negative or\n if it is greater than the number of elements in the list. *)\n val compute_path : t -> int -> path tzresult\n\n (** [check_path path pos elt expected_root] checks that an [elt] with path\n [path] at position [pos] has the [expected_root].\n\n Can fail with [Merkle_list_invalid_position] if [pos] is negative or\n if it is greater than the number of elements in the list. *)\n val check_path : path -> int -> elt -> h -> bool tzresult\n\n (** [path_depth path] returns the depth of the tree [path] is\n related to. *)\n val path_depth : path -> int\n\n val elt_bytes : elt -> Bytes.t\n\n (**/**)\n\n module Internal_for_tests : sig\n val path_to_list : path -> h list\n\n (** Checks equality between Merkle lists. Outside of testing, clients should\n use [root] for comparison. *)\n val equal : t -> t -> bool\n\n val to_list : t -> h list\n end\nend\n\nmodule Make (El : sig\n type t\n\n val to_bytes : t -> bytes\nend)\n(H : S.HASH) : T with type elt = El.t and type h = H.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error += Merkle_list_invalid_position\n\nlet max_depth ~count_limit =\n (* We assume that the Merkle_tree implementation computes a tree in a\n logarithmic size of the number of leaves. *)\n let log2 n = Z.numbits (Z.of_int n) in\n log2 count_limit\n\nlet () =\n register_error_kind\n `Temporary\n ~id:\"Merkle_list_invalid_position\"\n ~title:\"Merkle_list_invalid_position\"\n ~description:\"Merkle_list_invalid_position\"\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" \"Merkle_list_invalid_position\")\n Data_encoding.empty\n (function Merkle_list_invalid_position -> Some () | _ -> None)\n (fun () -> Merkle_list_invalid_position)\n\nmodule type T = sig\n type t\n\n type h\n\n type elt\n\n type path\n\n val dummy_path : path\n\n val pp_path : Format.formatter -> path -> unit\n\n val nil : t\n\n val empty : h\n\n val root : t -> h\n\n val snoc : t -> elt -> t\n\n val snoc_tr : t -> elt -> t\n\n val compute : elt list -> h\n\n val path_encoding : path Data_encoding.t\n\n val bounded_path_encoding : ?max_length:int -> unit -> path Data_encoding.t\n\n val compute_path : t -> int -> path tzresult\n\n val check_path : path -> int -> elt -> h -> bool tzresult\n\n val path_depth : path -> int\n\n val elt_bytes : elt -> Bytes.t\n\n module Internal_for_tests : sig\n val path_to_list : path -> h list\n\n val equal : t -> t -> bool\n\n val to_list : t -> h list\n end\nend\n\nmodule Make (El : sig\n type t\n\n val to_bytes : t -> bytes\nend)\n(H : S.HASH) : T with type elt = El.t and type h = H.t = struct\n type h = H.t\n\n type elt = El.t\n\n let elt_bytes = El.to_bytes\n\n (*\n The goal of this structure is to model an append-only list.\n Its internal representation is that of a binary tree whose\n leaves are all at the same level (the tree's height).\n\n To insert a new element in a full tree t, we create a new root with t\n as its left subtree and a new tree t' as its right subtree. t' is just a\n left-spine of the same height as t. Visually,\n\n t = / \\ t' = / snoc 4 t = / \\\n /\\ /\\ / / \\ /\n 0 1 2 3 4 /\\ /\\ /\n 0 1 2 3 4\n\n Then, this is a balanced tree by construction.\n As the key in the tree for a given position is the position's\n binary decomposition of size height(tree), the tree is dense.\n For that reason, the use of extenders is not needed.\n *)\n\n type tree = Empty | Leaf of h | Node of (h * tree * tree)\n\n (* The tree has the following invariants:\n A node [Node left right] if valid iff\n 1. [right] is Empty and [left] is not Empty, or\n 2. [right] is not Empty and [left] is full\n Additionally:\n [t.depth] is the height of [t.tree] and\n [t.next_pos] is the number of leaves in [t.tree] *)\n type t = {tree : tree; depth : int; next_pos : int}\n\n type path = h list\n\n let dummy_path = []\n\n let pp_path ppf =\n Format.fprintf\n ppf\n \"%a\"\n (Format.pp_print_list\n ~pp_sep:(fun fmt () -> Format.fprintf fmt \";@ \")\n H.pp)\n\n let empty = H.zero\n\n let root = function Empty -> empty | Leaf h -> h | Node (h, _, _) -> h\n\n let nil = {tree = Empty; depth = 0; next_pos = 0}\n\n let hash_elt el = H.hash_bytes [elt_bytes el]\n\n let leaf_of el = Leaf (hash_elt el)\n\n let hash2 h1 h2 = H.(hash_bytes [to_bytes h1; to_bytes h2])\n\n let node_of t1 t2 = Node (hash2 (root t1) (root t2), t1, t2)\n\n (* to_bin computes the [depth]-long binary representation of [pos]\n (left-padding with 0s if required). This corresponds to the tree traversal\n of en element at position [pos] (false = left, true = right).\n\n Pre-condition: pos >= 0 /| pos < 2^depth\n Post-condition: len(to_bin pos depth) = depth *)\n let to_bin ~pos ~depth =\n let rec aux acc pos depth =\n let pos', dir = (pos / 2, pos mod 2) in\n match depth with\n | 0 -> acc\n | d -> aux (Compare.Int.(dir = 1) :: acc) pos' (d - 1)\n in\n aux [] pos depth\n\n (* Constructs a tree of a given depth in which every right subtree is empty\n * and the only leaf contains the hash of el. *)\n let make_spine_with el =\n let rec aux left = function\n | 0 -> left\n | d -> (aux [@tailcall]) (node_of left Empty) (d - 1)\n in\n aux (leaf_of el)\n\n let snoc t (el : elt) =\n let rec traverse tree depth key =\n match (tree, key) with\n | Node (_, t_left, Empty), true :: _key ->\n (* The base case where the left subtree is full and we start\n * the right subtree by creating a new tree the size of the remaining\n * depth and placing the new element in its leftmost position. *)\n let t_right = make_spine_with el (depth - 1) in\n node_of t_left t_right\n | Node (_, t_left, Empty), false :: key ->\n (* Traversing left, the left subtree is not full (and thus the right\n * subtree is empty). Recurse on left subtree. *)\n let t_left = traverse t_left (depth - 1) key in\n node_of t_left Empty\n | Node (_, t_left, t_right), true :: key ->\n (* Traversing right, the left subtree is full.\n * Recurse on right subtree *)\n let t_right = traverse t_right (depth - 1) key in\n node_of t_left t_right\n | _, _ ->\n (* Impossible by construction of the tree and of the key.\n * See [tree] invariants and [to_bin]. *)\n assert false\n in\n\n let tree', depth' =\n match (t.tree, t.depth, t.next_pos) with\n | Empty, 0, 0 -> (node_of (leaf_of el) Empty, 1)\n | tree, depth, pos when Int32.(equal (shift_left 1l depth) (of_int pos))\n ->\n let t_right = make_spine_with el depth in\n (node_of tree t_right, depth + 1)\n | tree, depth, pos ->\n let key = to_bin ~pos ~depth in\n (traverse tree depth key, depth)\n in\n {tree = tree'; depth = depth'; next_pos = t.next_pos + 1}\n\n type zipper = Left of zipper * tree | Right of tree * zipper | Top\n\n let rec rebuild_tree z t =\n match z with\n | Top -> t\n | Left (z, r) -> (rebuild_tree [@tailcall]) z (node_of t r)\n | Right (l, z) -> (rebuild_tree [@tailcall]) z (node_of l t)\n\n let snoc_tr t (el : elt) =\n let rec traverse (z : zipper) tree depth key =\n match (tree, key) with\n | Node (_, t_left, Empty), true :: _key ->\n let t_right = make_spine_with el (depth - 1) in\n rebuild_tree z (node_of t_left t_right)\n | Node (_, t_left, Empty), false :: key ->\n let z = Left (z, Empty) in\n (traverse [@tailcall]) z t_left (depth - 1) key\n | Node (_, t_left, t_right), true :: key ->\n let z = Right (t_left, z) in\n (traverse [@tailcall]) z t_right (depth - 1) key\n | _, _ ->\n (* Impossible by construction of the tree and of the key.\n * See [tree] invariants and [to_bin]. *)\n assert false\n in\n\n let tree', depth' =\n match (t.tree, t.depth, t.next_pos) with\n | Empty, 0, 0 -> (node_of (leaf_of el) Empty, 1)\n | tree, depth, pos when Int32.(equal (shift_left 1l depth) (of_int pos))\n ->\n let t_right = make_spine_with el depth in\n (node_of tree t_right, depth + 1)\n | tree, depth, pos ->\n let key = to_bin ~pos ~depth in\n (traverse Top tree depth key, depth)\n in\n {tree = tree'; depth = depth'; next_pos = t.next_pos + 1}\n\n let rec tree_to_list = function\n | Empty -> []\n | Leaf h -> [h]\n | Node (_, t_left, t_right) -> tree_to_list t_left @ tree_to_list t_right\n\n let path_encoding = Data_encoding.(list H.encoding)\n\n let bounded_path_encoding ?max_length () =\n match max_length with\n | None -> path_encoding\n | Some max_length -> Data_encoding.((list ~max_length) H.encoding)\n\n (* The order of the path is from bottom to top *)\n let compute_path {tree; depth; next_pos} pos =\n if Compare.Int.(pos < 0 || pos >= next_pos) then\n error Merkle_list_invalid_position\n else\n let key = to_bin ~pos ~depth in\n let rec aux acc tree key =\n match (tree, key) with\n | Leaf _, [] -> ok acc\n | Node (_, l, r), b :: key ->\n if b then aux (root l :: acc) r key else aux (root r :: acc) l key\n | _ -> error Merkle_list_invalid_position\n in\n aux [] tree key\n\n let check_path path pos el expected_root =\n let depth = List.length path in\n if\n Compare.Int.(pos >= 0)\n && Compare.Z.(Z.of_int pos < Z.shift_left Z.one depth)\n then\n let key = List.rev @@ to_bin ~pos ~depth in\n let computed_root =\n List.fold_left\n (fun acc (sibling, b) ->\n if b then hash2 sibling acc else hash2 acc sibling)\n (hash_elt el)\n (List.combine_drop path key)\n in\n ok (H.equal computed_root expected_root)\n else error Merkle_list_invalid_position\n\n let path_depth path = List.length path\n\n let compute l =\n let rec aux l =\n let rec pairs acc = function\n | [] -> List.rev acc\n | [x] -> List.rev (hash2 x empty :: acc)\n | x :: y :: xs -> pairs (hash2 x y :: acc) xs\n in\n match pairs [] l with [] -> empty | [h] -> h | pl -> aux pl\n in\n aux (List.map hash_elt l)\n\n let root t = root t.tree\n\n module Internal_for_tests = struct\n let path_to_list x = x\n\n let to_list tree = tree_to_list tree.tree\n\n let equal t1 t2 =\n let rec eq_tree t1 t2 =\n match (t1, t2) with\n | Empty, Empty -> true\n | Leaf h1, Leaf h2 -> H.equal h1 h2\n | Node (h1, l1, r1), Node (h2, l2, r2) ->\n H.equal h1 h2 && eq_tree l1 l2 && eq_tree r1 r2\n | _ -> false\n in\n Compare.Int.equal t1.depth t2.depth\n && Compare.Int.equal t1.next_pos t2.next_pos\n && eq_tree t1.tree t2.tree\n end\nend\n" ;
} ;
{ name = "Bitset" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** A bitset is a compact structure to store a set of integers. *)\ntype t\n\ntype error += Invalid_position of int\n\nval encoding : t Data_encoding.t\n\n(** A bitset encoding the empty set. *)\nval empty : t\n\n(** [mem field i] returns [true] iff [i] has been added in [field].\n\n This functions returns [Invalid_input i] if [i] is negative. *)\nval mem : t -> int -> bool tzresult\n\n(** [add field i] returns a new bitset which contains [i] in\n addition to the previous integers of [field].\n\n This functions returns [Invalid_input i] if [i] is negative. *)\nval add : t -> int -> t tzresult\n\n(** [from_list positions] folds [add] over the [positions] starting from [empty].\n This function returns [Invalid_input i] if [i] is negative and appears in\n [positions]. *)\nval from_list : int list -> t tzresult\n\n(** [fill ~length] is equivalent to setting all bits for positions in\n [0, length - 1] to [one]. i.e., to [from_list (0 -- size -1)] or to\n [(2 ^ length) - 1]. But it's more efficient than folding on individual\n positions to set them.\n\n The function returns [Invalid_position length] if [length] is negative.\n*)\nval fill : length:int -> t tzresult\n\n(** [inter set_l set_r] returns [set] which is result of the\n intersection of [set_l] and [set_r]. *)\nval inter : t -> t -> t\n\n(** [diff set_l set_r] returns a [set] containing fiels in [set_l]\n that are not in [set_r]. *)\nval diff : t -> t -> t\n\n(** [occupied_size_in_bits bitset] returns the current number of bits\n occupied by the [bitset]. *)\nval occupied_size_in_bits : t -> int\n\nmodule Internal_for_tests : sig\n val to_z : t -> Z.t\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t = Z.t\n\ntype error += Invalid_position of int\n\nlet encoding = Data_encoding.z\n\nlet empty = Z.zero\n\nlet mem field pos =\n error_when Compare.Int.(pos < 0) (Invalid_position pos) >>? fun () ->\n ok @@ Z.testbit field pos\n\nlet add field pos =\n error_when Compare.Int.(pos < 0) (Invalid_position pos) >>? fun () ->\n ok @@ Z.logor field Z.(shift_left one pos)\n\nlet from_list positions = List.fold_left_e add empty positions\n\nlet fill ~length =\n error_when Compare.Int.(length < 0) (Invalid_position length) >>? fun () ->\n ok Z.(pred (shift_left one length))\n\nlet inter = Z.logand\n\nlet diff b1 b2 = Z.logand b1 (Z.lognot b2)\n\nlet () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"bitfield_invalid_position\"\n ~title:\"Invalid bitfield\226\128\153s position\"\n ~description:\"Bitfields does not accept negative positions\"\n (obj1 (req \"position\" int31))\n (function Invalid_position i -> Some i | _ -> None)\n (fun i -> Invalid_position i)\n\nlet occupied_size_in_bits = Z.numbits\n\nmodule Internal_for_tests = struct\n let to_z z = z\nend\n" ;
} ;
{ name = "Bounded_history_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** A bounded cache associating values to keys.\n\nThis data structure is basically a bounded association table that stores\n(a finite number of) given [(key, value)], with the following properties:\n{ul\n{li The insertion ordering is remembered / important. When the structure is full,\n older entries are removed to insert new ones;}\n{li Stored keys are unique in the data-structure.}\n}\n*)\n\nmodule type NAME = sig\n val name : string\nend\n\n(** The required interface for keys stored in the table. *)\nmodule type KEY = sig\n type t\n\n val compare : t -> t -> int\n\n val pp : Format.formatter -> t -> unit\n\n val encoding : t Data_encoding.t\nend\n\n(** The required interface for values stored in the table. *)\nmodule type VALUE = sig\n type t\n\n val equal : t -> t -> bool\n\n val pp : Format.formatter -> t -> unit\n\n val encoding : t Data_encoding.t\nend\n\n(** The exported interface of the data structure. *)\nmodule type S = sig\n type t\n\n type key\n\n type value\n\n (** [empty ~capacity] returns a new table whose maximum capacity is given. *)\n val empty : capacity:int64 -> t\n\n (** Encoding for values of type {!t} *)\n val encoding : t Data_encoding.t\n\n (** Pretty-printer for values of type {!t} *)\n val pp : Format.formatter -> t -> unit\n\n (** [find key t] returns [Some value] if there exists some [value] associated\n to [key] in the table, and [None] otherwise. *)\n val find : key -> t -> value option\n\n type error +=\n | Key_bound_to_different_value of {\n key : key;\n existing_value : value;\n given_value : value;\n }\n\n (** [remember key value t] inserts a new entry [(key |-> value)] in [t].\n\n If [key] already exists in [t], its associated binding [value'] should\n be equal to [value]. In this case, [t] is returned unchanged. Otherwise,\n an error [Key_bound_to_different_value] is returned.\n\n If [key] is not already present in [t], the new binding (key |-> value) is\n inserted in [t]. If the number of elements would exceed [t]'s capacity\n after the insertion of the new binding, the oldest binding is removed\n from [t].\n\n The structure [t] is returned unchanged if its [capacity] is negative or\n null.\n *)\n val remember : key -> value -> t -> t tzresult\n\n module Internal_for_tests : sig\n (** A more flexible [empty] function for testing purpose. *)\n val empty : capacity:int64 -> next_index:int64 -> t\n\n (** [keys t] returns the keys of the entries stored in [t] in the order of\n their insertion. *)\n val keys : t -> key list\n end\nend\n\nmodule Make (Name : NAME) (Key : KEY) (Value : VALUE) :\n S with type key = Key.t and type value = Value.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule type NAME = sig\n val name : string\nend\n\nmodule type KEY = sig\n type t\n\n val compare : t -> t -> int\n\n val pp : Format.formatter -> t -> unit\n\n val encoding : t Data_encoding.t\nend\n\nmodule type VALUE = sig\n type t\n\n val equal : t -> t -> bool\n\n val pp : Format.formatter -> t -> unit\n\n val encoding : t Data_encoding.t\nend\n\nmodule type S = sig\n type t\n\n type key\n\n type value\n\n val empty : capacity:int64 -> t\n\n val encoding : t Data_encoding.t\n\n val pp : Format.formatter -> t -> unit\n\n val find : key -> t -> value option\n\n type error +=\n | Key_bound_to_different_value of {\n key : key;\n existing_value : value;\n given_value : value;\n }\n\n val remember : key -> value -> t -> t tzresult\n\n module Internal_for_tests : sig\n val empty : capacity:int64 -> next_index:int64 -> t\n\n val keys : t -> key list\n end\nend\n\nmodule Make (Name : NAME) (Key : KEY) (Value : VALUE) :\n S with type key = Key.t and type value = Value.t = struct\n type key = Key.t\n\n type value = Value.t\n\n module Int64_map = Map.Make (Int64)\n module Map = Map.Make (Key)\n\n type t = {\n events : value Map.t;\n (** Values stored in the structure, indexes with the keys. *)\n sequence : key Int64_map.t;\n (** An additional map from int64 indexes to keys, to be able\n to remove old entries when the structure is full. *)\n capacity : int64;\n (** The max number of the entries in the structure. Once the maximum size\n is reached, older entries are deleted to free space for new ones. *)\n next_index : int64;\n (** The index to use for the next entry to add in the structure. *)\n oldest_index : int64;\n (** The oldest index of the (oldest) entry that has been added to the\n data structure. If the structure is empty, [oldest_index] is\n equal to [next_index]. *)\n size : int64;\n (** Counts the number of entries that are stored in history. It\n satisfies the invariant: `0 <= size <= capacity` *)\n }\n\n let encoding : t Data_encoding.t =\n let open Data_encoding in\n let events_encoding =\n Data_encoding.conv\n Map.bindings\n (fun l -> Map.add_seq (List.to_seq l) Map.empty)\n Data_encoding.(list (tup2 Key.encoding Value.encoding))\n in\n let sequence_encoding =\n conv\n Int64_map.bindings\n (List.fold_left (fun m (k, v) -> Int64_map.add k v m) Int64_map.empty)\n (list (tup2 int64 Key.encoding))\n in\n conv\n (fun {events; sequence; capacity; next_index; oldest_index; size} ->\n (events, sequence, capacity, next_index, oldest_index, size))\n (fun (events, sequence, capacity, next_index, oldest_index, size) ->\n {events; sequence; capacity; next_index; oldest_index; size})\n (obj6\n (req \"events\" events_encoding)\n (req \"sequence\" sequence_encoding)\n (req \"capacity\" int64)\n (req \"next_index\" int64)\n (req \"oldest_index\" int64)\n (req \"size\" int64))\n\n let pp fmt {events; sequence; capacity; size; oldest_index; next_index} =\n Map.bindings events |> fun bindings ->\n Int64_map.bindings sequence |> fun sequence_bindings ->\n let pp_binding fmt (hash, history_proof) =\n Format.fprintf fmt \"@[%a -> %a@;@]\" Key.pp hash Value.pp history_proof\n in\n let pp_sequence_binding fmt (counter, hash) =\n Format.fprintf fmt \"@[%s -> %a@;@]\" (Int64.to_string counter) Key.pp hash\n in\n Format.fprintf\n fmt\n \"@[<hov 2>History:@;\\\n \\ { capacity: %Ld;@;\\\n \\ current size: %Ld;@;\\\n \\ oldest index: %Ld;@;\\\n \\ next_index : %Ld;@;\\\n \\ bindings: %a;@;\\\n \\ sequence: %a; }@]\"\n capacity\n size\n oldest_index\n next_index\n (Format.pp_print_list pp_binding)\n bindings\n (Format.pp_print_list pp_sequence_binding)\n sequence_bindings\n\n let empty ~capacity =\n let next_index = 0L in\n {\n events = Map.empty;\n sequence = Int64_map.empty;\n capacity;\n next_index;\n oldest_index = next_index;\n size = 0L;\n }\n\n type error +=\n | Key_bound_to_different_value of {\n key : key;\n existing_value : value;\n given_value : value;\n }\n\n let () =\n assert (not (String.equal Name.name \"\")) ;\n register_error_kind\n `Temporary\n ~id:\n (Format.sprintf\n \"Bounded_history_repr.%s.key_bound_to_different_value\"\n Name.name)\n ~title:(Name.name ^ \": Key already bound to a different value.\")\n ~description:\n (Name.name\n ^ \": Remember called with a key that is already bound to a different\\n\\\n \\ value.\")\n Data_encoding.(\n obj3\n (req \"key\" Key.encoding)\n (req \"existing_value\" Value.encoding)\n (req \"given_value\" Value.encoding))\n (function\n | Key_bound_to_different_value {key; existing_value; given_value} ->\n Some (key, existing_value, given_value)\n | _ -> None)\n (fun (key, existing_value, given_value) ->\n Key_bound_to_different_value {key; existing_value; given_value})\n\n let remember key value t =\n let open Result_syntax in\n if Compare.Int64.(t.capacity <= 0L) then return t\n else\n match Map.find key t.events with\n | Some value' when not (Value.equal value value') ->\n error\n @@ Key_bound_to_different_value\n {key; existing_value = value'; given_value = value}\n | _ -> (\n let events = Map.add key value t.events in\n let current_index = t.next_index in\n let next_index = Int64.succ current_index in\n let t =\n {\n events;\n sequence = Int64_map.add current_index key t.sequence;\n capacity = t.capacity;\n next_index;\n oldest_index = t.oldest_index;\n size = Int64.succ t.size;\n }\n in\n (* A negative size means that [t.capacity] is set to [Int64.max_int]\n and that the structure is full, so adding a new entry makes the size\n overflows. In this case, we remove an element in the else branch to\n keep the size of the structure equal to [Int64.max_int] at most. *)\n if Compare.Int64.(t.size > 0L && t.size <= t.capacity) then return t\n else\n let l = t.oldest_index in\n match Int64_map.find l t.sequence with\n | None ->\n (* If t.size > t.capacity > 0, there is necessarily\n an entry whose index is t.oldest_index in [sequence]. *)\n assert false\n | Some h ->\n let sequence = Int64_map.remove l t.sequence in\n let events = Map.remove h events in\n return\n {\n next_index = t.next_index;\n capacity = t.capacity;\n size = t.capacity;\n oldest_index = Int64.succ t.oldest_index;\n sequence;\n events;\n })\n\n let find key t = Map.find_opt key t.events\n\n module Internal_for_tests = struct\n let empty ~capacity ~next_index =\n {(empty ~capacity) with next_index; oldest_index = next_index}\n\n let keys {sequence; oldest_index; _} =\n let l = Int64_map.bindings sequence in\n (* All entries with an index greater than oldest_index are well ordered.\n There are put in the [lp] list. Entries with an index smaller than\n oldest_index are also well ordered, but they should come after\n elements in [lp]. This happens in theory when the index reaches\n max_int and then overflows. *)\n let ln, lp =\n List.partition_map\n (fun (n, h) ->\n if Compare.Int64.(n < oldest_index) then Left h else Right h)\n l\n in\n (* do a tail recursive concatenation lp @ ln *)\n List.rev_append (List.rev lp) ln\n end\nend\n" ;
} ;
{ name = "Skip_list_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module provides an implementation of the skip list data structure. *)\n\n(** Basic signature for a monad. *)\nmodule type MONAD = sig\n type 'a t\n\n val bind : 'a t -> ('a -> 'b t) -> 'b t\n\n val return : 'a -> 'a t\nend\n\n(** A skip list represents a sequence of values. There are three main\n differences between these [skip list]s and OCaml standard [list]s:\n\n 1. A skip list cannot be empty.\n\n 2. A skip list grows at its end.\n\n 3. Each cell of the skip list provides several back pointers\n allowing to *skip* chunk of ancestors of the sequence to directly\n jump to a given position. More precisely, given a [basis]\n parameter, the i-th back pointers of element number [n] in the\n sequence points to [n - n mod basis^i - 1]. The element number [n]\n in the sequence contains [log_basis n] back pointers.\n\n The skip list is defined by a pair of dereferencing function\n of type ['ptr -> ('content, 'ptr) cell] and the last cell\n of the sequence. The maintainance of this pair is left to the client.\n In particular, the client is responsible to correctly bind a cell\n to each back pointers reachable from the last cell.\n\n*)\nmodule type S = sig\n (** A cell in the skip list carrying a given ['content] and back\n pointers of type ['ptr]. *)\n type ('content, 'ptr) cell\n\n val pp :\n pp_ptr:(Format.formatter -> 'ptr -> unit) ->\n pp_content:(Format.formatter -> 'content -> unit) ->\n Format.formatter ->\n ('content, 'ptr) cell ->\n unit\n\n val equal :\n ('ptr -> 'ptr -> bool) ->\n ('content -> 'content -> bool) ->\n ('content, 'ptr) cell ->\n ('content, 'ptr) cell ->\n bool\n\n val encoding :\n 'ptr Data_encoding.t ->\n 'content Data_encoding.t ->\n ('content, 'ptr) cell Data_encoding.t\n\n (** [index cell] returns the position of [cell] in the sequence. *)\n val index : (_, _) cell -> Z.t\n\n (** [content cell] is the content carried by the [cell]. *)\n val content : ('content, 'ptr) cell -> 'content\n\n (** [back_pointer cell i] returns [Some ptr] if [ptr] is the\n [i]-th back pointer of [cell]. Returns [None] if the cell\n contains less than [i + 1] back pointers. *)\n val back_pointer : ('content, 'ptr) cell -> int -> 'ptr option\n\n (** [back_pointers cell] returns the back pointers of [cell]. *)\n val back_pointers : ('content, 'ptr) cell -> 'ptr list\n\n (** [genesis content] is the first cell of a skip list. It has\n no back pointers. *)\n val genesis : 'content -> ('content, 'ptr) cell\n\n (** [next ~prev_cell ~prev_cell_ptr content] creates a new cell\n that carries some [content], that follows [prev_cell]. *)\n val next :\n prev_cell:('content, 'ptr) cell ->\n prev_cell_ptr:'ptr ->\n 'content ->\n ('content, 'ptr) cell\n\n type ('ptr, 'content) search_cell_result =\n | Found of ('ptr, 'content) cell\n | Nearest of {\n lower : ('ptr, 'content) cell;\n upper : ('ptr, 'content) cell option;\n }\n | No_exact_or_lower_ptr\n | Deref_returned_none\n\n type ('ptr, 'content) search_result = {\n rev_path : ('ptr, 'content) cell list;\n last_cell : ('ptr, 'content) search_cell_result;\n }\n\n val pp_search_result :\n pp_cell:(Format.formatter -> ('ptr, 'content) cell -> unit) ->\n Format.formatter ->\n ('ptr, 'content) search_result ->\n unit\n\n module type MONADIC = sig\n (** Type of results for monadic functions. *)\n type 'a result\n\n (** [find ~deref ~cell_ptr ~target_index] returns [Some cell] where [cell] is\n the cell at position [target_index]. This is done by dereferencing the last\n pointer of the path returned by {!back_path}. *)\n val find :\n deref:('ptr -> ('content, 'ptr) cell option result) ->\n cell_ptr:'ptr ->\n target_index:Z.t ->\n ('content, 'ptr) cell option result\n\n (** [back_path ~deref ~cell_ptr ~target_index] returns [Some path]\n where [path] is a sequence of back pointers to traverse to go\n from [cell_ptr] to the cell at position [target_index] in the\n sequence denoted by [(deref, cell_ptr)]. *)\n val back_path :\n deref:('ptr -> ('content, 'ptr) cell option result) ->\n cell_ptr:'ptr ->\n target_index:Z.t ->\n 'ptr list option result\n\n (** [valid_back_path ~equal_ptr ~deref ~cell_ptr ~target_ptr path]\n returns [true] iff [path] is a valid and minimal path from\n [cell_ptr] to [target_ptr] in the skip list denoted by\n [(deref, cell_ptr)]. *)\n val valid_back_path :\n equal_ptr:('ptr -> 'ptr -> bool) ->\n deref:('ptr -> ('content, 'ptr) cell option result) ->\n cell_ptr:'ptr ->\n target_ptr:'ptr ->\n 'ptr list ->\n bool result\n\n (** [search ~deref ~compare ~cell] allows to find a cell of the skip\n list according to its content. This function assumes that the\n content of the cells is in increasing order according to the\n ordering defined by the function [compare]. In other words, this\n function assumes that [compare] is a function that returns a\n negative integer for cells before the target and a positive\n integer for cells after the target. The value returned by this\n function is [{rev_path; last_cell}] such that.\n\n - [rev_path = []] if and only if [compare (content cell) > 0]\n\n - For all the cases below, if there is a path from cell [A] to\n cell [B], [rev_path] contains the list of cells to go from [B] to\n [A]. Consequently, the first element of [rev_path] is [B].\n Except for [Nearest_lower], this path is a minimal path.\n\n - [last_pointer = Deref_returned_none] if [deref] fails to\n associate a cell to a pointer during the search. In that case,\n [rev_path] is a path from [cell] to [candidate] where [candidate]\n is the last cell for which candidate did not fail and such that\n [compare (content (candidate)) > 0].\n\n - [last_pointer = No_exact_or_lower_ptr] if for all cell of the\n skip list, [compare (content cell) > 0]. In that case, [rev_path]\n is a path from [cell] to the genesis cell.\n\n - [last_pointer = Found target] if there is a cell [target] such\n that [compare (content target) = 0] and a path from [cell] to\n [target]. In that case, [rev_path] is the minimal path from\n [cell] to [target].\n\n - [last_pointer = Nearest_lower {lower;upper}] if there is no\n cell in the skip list such that [compare (content cell) = 0]. In\n that case [lower] is the unique cell such that [compare (content\n lower) < 0] and for all other cells [candidate] such that\n [compare (content candidate) < 0] then there is a path from\n [lower] to [candidate]. [upper], if it exists is the successor\n cell to [lower], i.e. [deref ((back_pointer upper) 0) = Some\n lower]. In that case, [rev_path] is a path from [cell] to\n [lower]. This path is *NOT* minimal but almost. The path is\n minimal from [cell] to [upper=Some up]. By minimality, the path\n is logarithmic. Consequently, since there is a direct pointer\n from [up] to [lower], the passe to [lower] is also\n logarithmic. *)\n val search :\n deref:('ptr -> ('content, 'ptr) cell option result) ->\n compare:('content -> int) ->\n cell:('content, 'ptr) cell ->\n ('content, 'ptr) search_result result\n end\n\n (** Functions in the empty monad are accessible directly. *)\n include MONADIC with type 'a result := 'a\n\n (** This module contains functions in the {!Lwt} monad. *)\n module Lwt : MONADIC with type 'a result := 'a Lwt.t\n\n (** This functor can be used to build monadic functions for the skip list. *)\n module Make_monadic (M : MONAD) : MONADIC with type 'a result := 'a M.t\nend\n\nmodule Make (_ : sig\n val basis : int\nend) : S\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule type MONAD = sig\n type 'a t\n\n val bind : 'a t -> ('a -> 'b t) -> 'b t\n\n val return : 'a -> 'a t\nend\n\nmodule type S = sig\n type ('content, 'ptr) cell\n\n val pp :\n pp_ptr:(Format.formatter -> 'ptr -> unit) ->\n pp_content:(Format.formatter -> 'content -> unit) ->\n Format.formatter ->\n ('content, 'ptr) cell ->\n unit\n\n val equal :\n ('ptr -> 'ptr -> bool) ->\n ('content -> 'content -> bool) ->\n ('content, 'ptr) cell ->\n ('content, 'ptr) cell ->\n bool\n\n val encoding :\n 'ptr Data_encoding.t ->\n 'content Data_encoding.t ->\n ('content, 'ptr) cell Data_encoding.t\n\n val index : (_, _) cell -> Z.t\n\n val content : ('content, 'ptr) cell -> 'content\n\n val back_pointer : ('content, 'ptr) cell -> int -> 'ptr option\n\n val back_pointers : ('content, 'ptr) cell -> 'ptr list\n\n val genesis : 'content -> ('content, 'ptr) cell\n\n val next :\n prev_cell:('content, 'ptr) cell ->\n prev_cell_ptr:'ptr ->\n 'content ->\n ('content, 'ptr) cell\n\n type ('ptr, 'content) search_cell_result =\n | Found of ('ptr, 'content) cell\n | Nearest of {\n lower : ('ptr, 'content) cell;\n upper : ('ptr, 'content) cell option;\n }\n | No_exact_or_lower_ptr\n | Deref_returned_none\n\n type ('ptr, 'content) search_result = {\n rev_path : ('ptr, 'content) cell list;\n last_cell : ('ptr, 'content) search_cell_result;\n }\n\n val pp_search_result :\n pp_cell:(Format.formatter -> ('ptr, 'content) cell -> unit) ->\n Format.formatter ->\n ('ptr, 'content) search_result ->\n unit\n\n module type MONADIC = sig\n type 'a result\n\n val find :\n deref:('ptr -> ('content, 'ptr) cell option result) ->\n cell_ptr:'ptr ->\n target_index:Z.t ->\n ('content, 'ptr) cell option result\n\n val back_path :\n deref:('ptr -> ('content, 'ptr) cell option result) ->\n cell_ptr:'ptr ->\n target_index:Z.t ->\n 'ptr list option result\n\n val valid_back_path :\n equal_ptr:('ptr -> 'ptr -> bool) ->\n deref:('ptr -> ('content, 'ptr) cell option result) ->\n cell_ptr:'ptr ->\n target_ptr:'ptr ->\n 'ptr list ->\n bool result\n\n val search :\n deref:('ptr -> ('content, 'ptr) cell option result) ->\n compare:('content -> int) ->\n cell:('content, 'ptr) cell ->\n ('content, 'ptr) search_result result\n end\n\n include MONADIC with type 'a result := 'a\n\n module Lwt : MONADIC with type 'a result := 'a Lwt.t\n\n module Make_monadic (M : MONAD) : MONADIC with type 'a result := 'a M.t\nend\n\nmodule Make (Parameters : sig\n val basis : int\nend) : S = struct\n let () = assert (Compare.Int.(Parameters.basis >= 2))\n\n open Parameters\n\n (*\n\n A cell of a skip list with some [`content] and back pointers of\n type [`ptr].\n\n Invariants\n ----------\n\n - back_pointers[i]\n = Some (pointer to (index - (index mod (basis ** i)) - 1))\n (for all i < length back_pointers)\n - length back_pointers = log basis index\n\n Notes\n -----\n\n - The [index] field is not strictly required but helps in making\n the data structure more robust. Indeed, otherwise, we should\n also ask the client to provide the index of the cell to be\n built, which can be error-prone.\n\n - The back pointers of a cell are chosen from the back pointers of\n its predecessor (except for the genesis cell) and a pointer to this\n predecessor. This locality makes the insertion of new cell very\n efficient in practice.\n\n *)\n type ('content, 'ptr) cell = {\n content : 'content;\n back_pointers : 'ptr option FallbackArray.t;\n index : Z.t;\n }\n\n let equal equal_ptr equal_content cell1 cell2 =\n let equal_back_pointers b1 b2 =\n let open FallbackArray in\n Compare.Int.(length b1 = length b2)\n && fst\n @@ fold\n (fun (equal, i) h1 ->\n (equal && Option.equal equal_ptr h1 (get b2 i), i + 1))\n b1\n (true, 0)\n in\n let {content; back_pointers; index} = cell1 in\n equal_content content cell2.content\n && Compare.Z.equal index cell2.index\n && equal_back_pointers back_pointers cell2.back_pointers\n\n let index cell = cell.index\n\n let back_pointers_to_list a =\n FallbackArray.fold\n (fun l -> function\n | Some ptr -> ptr :: l\n | None -> (* By [cell] invariants. *) assert false)\n a\n []\n |> List.rev\n\n let pp ~pp_ptr ~pp_content fmt {content; back_pointers; index} =\n Format.fprintf\n fmt\n \"content: %a@,index: %s@,@[<hv 2>back_pointers:@ %a@]\"\n pp_content\n content\n (Z.to_string index)\n (Format.pp_print_list\n ~pp_sep:(fun fmt () -> Format.pp_print_string fmt \"; \")\n pp_ptr)\n (back_pointers_to_list back_pointers)\n\n let encoding ptr_encoding content_encoding =\n let of_list =\n FallbackArray.of_list ~fallback:None ~proj:(fun c -> Some c)\n in\n let to_list = back_pointers_to_list in\n let open Data_encoding in\n conv\n (fun {index; content; back_pointers} ->\n (index, content, to_list back_pointers))\n (fun (index, content, back_pointers) ->\n {index; content; back_pointers = of_list back_pointers})\n (obj3\n (req \"index\" n)\n (req \"content\" content_encoding)\n (req \"back_pointers\" (list ptr_encoding)))\n\n let content cell = cell.content\n\n let back_pointers cell = back_pointers_to_list cell.back_pointers\n\n let genesis content =\n {index = Z.zero; content; back_pointers = FallbackArray.make 0 None}\n\n let back_pointer cell i = FallbackArray.get cell.back_pointers i\n\n (* Precondition: i < length cell.back_pointers *)\n let back_pointer_unsafe cell i =\n match FallbackArray.get cell.back_pointers i with\n | Some ptr -> ptr\n | None -> (* By precondition and invariants of cells. *) assert false\n\n let next ~prev_cell ~prev_cell_ptr content =\n let index = Z.succ prev_cell.index in\n let back_pointers =\n let rec aux power accu i =\n if Compare.Z.(index < power) then List.rev accu\n else\n let back_pointer_i =\n if Compare.Z.(Z.rem index power = Z.zero) then prev_cell_ptr\n else\n (* The following call is valid because of\n - [i < List.length prev_cell.back_pointer]\n because [log_basis index = log_basis prev_cell.index]\n - the invariants of [prev_cell] *)\n back_pointer_unsafe prev_cell i\n in\n let accu = back_pointer_i :: accu in\n aux Z.(mul power (of_int basis)) accu (i + 1)\n in\n aux Z.one [] 0\n in\n let back_pointers =\n FallbackArray.of_list ~fallback:None ~proj:Option.some back_pointers\n in\n {index; content; back_pointers}\n\n (* returns the array of [basis^i] forall [i < len (back_pointers cell)] *)\n let list_powers cell =\n let rec aux n prev p =\n if Compare.Int.(n <= 0) then List.rev p\n else aux (n - 1) (basis * prev) (prev :: p)\n in\n FallbackArray.of_list\n ~fallback:0\n ~proj:(fun x -> x)\n (aux (FallbackArray.length cell.back_pointers) 1 [])\n\n (*\n [back_pointers] are sorted in decreasing order of their pointing cell index\n in the list. So we can do a [binary_search] to find the [cell] with the\n smallest index that is greater than [target] in the list.\n\n More formally, min({c : cell | c.index >= target.index}) where [c] is one of\n the pointed cells in the array of back pointers of the [cell] parameter.\n *)\n let best_skip cell target_index powers =\n let open FallbackArray in\n let pointed_cell_index i =\n Z.(pred @@ sub cell.index (rem cell.index (of_int (get powers i))))\n in\n (* cell.index - (cell.index mod get powers i) - 1 in *)\n let rec binary_search start_idx end_idx =\n if Compare.Int.(start_idx >= end_idx) then Some start_idx\n else\n let mid_idx = start_idx + ((end_idx - start_idx) / 2) in\n let mid_cell_index = pointed_cell_index mid_idx in\n if Compare.Z.(mid_cell_index = target_index) then Some mid_idx\n else if Compare.Z.(mid_cell_index < target_index) then\n binary_search start_idx (mid_idx - 1)\n else\n let prev_mid_cell_index = pointed_cell_index (mid_idx + 1) in\n if Compare.Z.(prev_mid_cell_index = target_index) then\n Some (mid_idx + 1)\n else if Compare.Z.(prev_mid_cell_index < target_index) then\n (*\n If (mid_cell_index > target_index) &&\n (prev_mid_cell_index < target_index)\n then we found the closest cell to the target, which is mid_cell,\n so we return its index [mid_idx] in the array of back_pointers.\n *)\n Some mid_idx\n else binary_search (mid_idx + 1) end_idx\n in\n binary_search 0 (length cell.back_pointers - 1)\n\n type ('ptr, 'content) search_cell_result =\n | Found of ('ptr, 'content) cell\n | Nearest of {\n lower : ('ptr, 'content) cell;\n upper : ('ptr, 'content) cell option;\n }\n | No_exact_or_lower_ptr\n | Deref_returned_none\n\n type ('ptr, 'content) search_result = {\n rev_path : ('ptr, 'content) cell list;\n last_cell : ('ptr, 'content) search_cell_result;\n }\n\n let pp_rev_path ~pp_cell =\n Format.pp_print_list ~pp_sep:Format.pp_print_space pp_cell\n\n let pp_search_cell_result ~pp_cell fmt = function\n | Found cell -> Format.fprintf fmt \"Found(%a)\" pp_cell cell\n | Nearest {lower; upper} ->\n Format.fprintf\n fmt\n \"Nearest(lower=%a;upper=%a)\"\n pp_cell\n lower\n (Format.pp_print_option pp_cell)\n upper\n | No_exact_or_lower_ptr -> Format.fprintf fmt \"No_exact_or_lower_ptr\"\n | Deref_returned_none -> Format.fprintf fmt \"Deref_returned_none\"\n\n let pp_search_result ~pp_cell fmt {rev_path; last_cell} =\n Format.fprintf\n fmt\n \"{rev_path = %a; last_point = %a}\"\n (pp_rev_path ~pp_cell)\n rev_path\n (pp_search_cell_result ~pp_cell)\n last_cell\n\n module type MONADIC = sig\n type 'a result\n\n val find :\n deref:('ptr -> ('content, 'ptr) cell option result) ->\n cell_ptr:'ptr ->\n target_index:Z.t ->\n ('content, 'ptr) cell option result\n\n val back_path :\n deref:('ptr -> ('content, 'ptr) cell option result) ->\n cell_ptr:'ptr ->\n target_index:Z.t ->\n 'ptr list option result\n\n val valid_back_path :\n equal_ptr:('ptr -> 'ptr -> bool) ->\n deref:('ptr -> ('content, 'ptr) cell option result) ->\n cell_ptr:'ptr ->\n target_ptr:'ptr ->\n 'ptr list ->\n bool result\n\n val search :\n deref:('ptr -> ('content, 'ptr) cell option result) ->\n compare:('content -> int) ->\n cell:('content, 'ptr) cell ->\n ('content, 'ptr) search_result result\n end\n\n module Make_monadic (M : MONAD) : MONADIC with type 'a result := 'a M.t =\n struct\n module Monad_syntax = struct\n include M\n\n let ( let* ) = bind\n\n module Option = struct\n let (return [@ocaml.inline \"always\"]) = fun x -> M.return (Some x)\n\n let ( let* ) lo f =\n M.bind lo (function None -> M.return None | Some x -> f x)\n\n let ( let*? ) o f = match o with Some x -> f x | None -> M.return None\n end\n end\n\n let rev_back_path ~deref ~cell_ptr ~target_index =\n let open Monad_syntax.Option in\n let* cell = deref cell_ptr in\n let powers = list_powers cell in\n let rec aux path ptr =\n let path = ptr :: path in\n let* cell = deref ptr in\n let index = cell.index in\n if Compare.Z.(target_index = index) then return path\n else if Compare.Z.(target_index > index) then M.return None\n else\n let*? best_idx = best_skip cell target_index powers in\n let*? ptr = back_pointer cell best_idx in\n aux path ptr\n in\n aux [] cell_ptr\n\n let find ~deref ~cell_ptr ~target_index =\n let open Monad_syntax.Option in\n let* rev_back_path = rev_back_path ~deref ~cell_ptr ~target_index in\n let*? cell_ptr = List.hd rev_back_path in\n deref cell_ptr\n\n let back_path ~deref ~cell_ptr ~target_index =\n let open Monad_syntax.Option in\n let* rev_back_path = rev_back_path ~deref ~cell_ptr ~target_index in\n return (List.rev rev_back_path)\n\n let mem equal x l =\n let open FallbackArray in\n let n = length l in\n let rec aux idx =\n if Compare.Int.(idx >= n) then false\n else\n match get l idx with\n | None -> aux (idx + 1)\n | Some y -> if equal x y then true else aux (idx + 1)\n in\n aux 0\n\n let assume_some o f =\n let open Monad_syntax in\n let* o = o in\n match o with None -> return false | Some x -> f x\n\n let valid_back_path ~equal_ptr ~deref ~cell_ptr ~target_ptr path =\n let open Monad_syntax in\n assume_some (deref target_ptr) @@ fun target ->\n assume_some (deref cell_ptr) @@ fun cell ->\n let target_index = index target\n and cell_index = index cell\n and powers = list_powers cell in\n let rec valid_path index cell_ptr path =\n match (cell_ptr, path) with\n | final_cell, [] ->\n return\n (equal_ptr target_ptr final_cell\n && Compare.Z.(index = target_index))\n | cell_ptr, cell_ptr' :: path ->\n assume_some (deref cell_ptr) @@ fun cell ->\n assume_some (deref cell_ptr') @@ fun cell' ->\n if mem equal_ptr cell_ptr' cell.back_pointers then\n assume_some (return @@ best_skip cell target_index powers)\n @@ fun best_idx ->\n assume_some (return @@ back_pointer cell best_idx)\n @@ fun best_ptr ->\n let minimal = equal_ptr best_ptr cell_ptr' in\n let index' = cell'.index in\n if minimal then valid_path index' cell_ptr' path else return false\n else return false\n in\n match path with\n | [] -> return false\n | first_cell_ptr :: path ->\n if equal_ptr first_cell_ptr cell_ptr then\n valid_path cell_index cell_ptr path\n else return false\n\n let search (type ptr) ~(deref : ptr -> ('content, ptr) cell option M.t)\n ~compare ~cell =\n let open Monad_syntax in\n let ( = ), ( < ), ( > ) = Compare.Int.(( = ), ( < ), ( > )) in\n (* Given a cell, to compute the minimal path, we need to find the\n good back-pointer. This is done linearly with respect to the\n number of back-pointers. This number of back-pointers is\n logarithmic with respect to the number of non-empty\n inboxes. The complexity is consequently in O(log_2^2(n)). Since\n in practice, [n < 2^32], we have at most [1000] calls. Besides,\n the recursive function is tail recursive.\n\n The linear search could be turned into a dichotomy search if\n necessary. But since this piece of code won't be used in a\n carbonated function, we prefer to keep a simple implementation\n for the moment. *)\n let rec aux rev_path cell ix =\n (* Below, we call the [target] the cell for which [compare target = 0]. *)\n\n (* Invariant:\n\n - compare cell > target\n - ix >= 0\n - if cell <> genesis => ix < List.length (back_pointers cell)\n - \\exists path' rev_path = cell:path'\n *)\n let back_pointers_length = FallbackArray.length cell.back_pointers in\n if back_pointers_length = 0 then\n (* [cell] is the genesis cell. *)\n return {rev_path; last_cell = No_exact_or_lower_ptr}\n else\n let candidate_ptr =\n match back_pointer cell ix with\n | None ->\n (* At this point we have [cell <> genesis]. Consequently,\n thanks to the invariant of this function, we have [ix\n < List.length (back_pointers cell)]. Consequently, the\n call to [back_pointer] cannot fail. *)\n assert false\n | Some candidate_ptr -> candidate_ptr\n in\n let* derefed = deref candidate_ptr in\n match derefed with\n | None ->\n (* If we cannot dereference a pointer, We stop the search\n and returns the current path. *)\n return {rev_path; last_cell = Deref_returned_none}\n | Some next_cell -> (\n let comparison = compare next_cell.content in\n if comparison = 0 then\n (* We have found the target.*)\n let rev_path = next_cell :: rev_path in\n return {rev_path; last_cell = Found next_cell}\n else if comparison > 0 then\n if ix < back_pointers_length - 1 then\n (* There might be a short path by dereferencing the next pointer. *)\n aux rev_path cell (ix + 1)\n else\n (* The last pointer is still above the target. We are on the good track, *)\n let rev_path = next_cell :: rev_path in\n aux rev_path next_cell 0\n else if ix = 0 then\n (* We found a cell lower than the target. *)\n (* The first back pointers gives a cell below the target *)\n let rev_path = next_cell :: rev_path in\n return\n {\n rev_path;\n last_cell = Nearest {lower = next_cell; upper = Some cell};\n }\n else\n (* We found a cell lower than the target. *)\n (* The previous pointer was actually the good one. *)\n let good_candidate_ptr =\n match back_pointer cell (ix - 1) with\n | None -> assert false\n | Some candidate_ptr -> candidate_ptr\n in\n let* derefed = deref good_candidate_ptr in\n match derefed with\n | None ->\n (* We already dereferenced this pointer before. *)\n assert false\n | Some good_next_cell ->\n let rev_path = good_next_cell :: rev_path in\n aux rev_path good_next_cell 0)\n in\n let comparison = compare cell.content in\n if Compare.Int.(comparison = 0) then\n (* Particular case where the target is the start cell. *)\n return {rev_path = [cell]; last_cell = Found cell}\n else if Compare.Int.(comparison < 0) then\n return\n {rev_path = [cell]; last_cell = Nearest {lower = cell; upper = None}}\n else aux [cell] cell 0\n end\n\n include Make_monadic (struct\n type 'a t = 'a\n\n let (bind [@ocaml.inline \"always\"]) = ( |> )\n\n let[@ocaml.inline always] return x = x\n end)\n\n module Lwt = Make_monadic (Lwt)\nend\n" ;
} ;
{ name = "Context_binary_proof" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error += Expected_binary_proof\n\n(** [is_binary proof] will fail if [proof] does not claim to be a\n Merkle proof of a binary tree compatible with the one defined in\n [Context_binary].\n\n {b Note:} It is very important to systematically check this before\n calling the [verify_proof] exposed in the protocol, since this\n function does not discriminate between binary and 32-ary\n proofs. *)\nval check_is_binary : Context.Proof.tree Context.Proof.t -> unit tzresult\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error += Expected_binary_proof\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"Expected_binary_proof\"\n ~title:\"Expected binary proof\"\n ~description:\"An invalid proof has been submitted\"\n Data_encoding.empty\n (function Expected_binary_proof -> Some () | _ -> None)\n (fun () -> Expected_binary_proof)\n\n(* TODO: https://gitlab.com/tezos/tezos/-/issues/4386 Extracted and\n adapted from {!Tezos_context_memory}. Ideally, this function should\n be exported there.\n\n In a nutshell, the context library exposed by the environment is\n implemented such that it can verify proofs generated by both\n [Context] and [Context_binary], and the only thing that\n differentiate these proofs from its perspective is the second bit\n of the [version] field of the proof.\n\n To ensure we only consider proofs computed against a binary tree,\n we check said bit. This prevents a 32-ary proof to be accepted by\n the protocol in the case where a given key-value store has the same\n hash with both [Context] and [Context_binary] (something that\n happens when the tree contains only one entry). *)\nlet check_is_binary proof =\n let extract_bit v mask = Compare.Int.(v land mask <> 0) in\n let binary_mask = 0b10 in\n let is_binary = extract_bit proof.Context.Proof.version binary_mask in\n error_unless is_binary Expected_binary_proof\n" ;
} ;
{ name = "Michelson_v1_primitives" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error += (* `Permanent *) Unknown_primitive_name of string\n\ntype error += (* `Permanent *) Invalid_case of string\n\ntype error +=\n | (* `Permanent *)\n Invalid_primitive_name of\n string Micheline.canonical * Micheline.canonical_location\n\n(** Types of nodes in Michelson's AST. They fall into 4 categories:\n - types (prefixed with [T_]);\n - constants (prefixed with [D_]);\n - instructions (prefixed with [I_]);\n - keywords (prefixed with [K_]).\n\n Recall that Micheline is essentially just S-expressions with\n a few extra atom types for strings and numbers. This variant\n represents the values the [Prim] atoms in the Michelson subset\n of Micheline. Other types (such as ['a Micheline.canonical]) are\n frequently parameterized by this type. This gives us a strongly-typed\n subset of Micheline while keeping the set of primitives independent\n from the definition of Micheline for easier changes.\n*)\ntype prim =\n | K_parameter\n | K_storage\n | K_code\n | K_view\n | D_False\n | D_Elt\n | D_Left\n | D_None\n | D_Pair\n | D_Right\n | D_Some\n | D_True\n | D_Unit\n | D_Lambda_rec\n | I_PACK\n | I_UNPACK\n | I_BLAKE2B\n | I_SHA256\n | I_SHA512\n | I_ABS\n | I_ADD\n | I_AMOUNT\n | I_AND\n | I_BALANCE\n | I_CAR\n | I_CDR\n | I_CHAIN_ID\n | I_CHECK_SIGNATURE\n | I_COMPARE\n | I_CONCAT\n | I_CONS\n | I_CREATE_ACCOUNT\n | I_CREATE_CONTRACT\n | I_IMPLICIT_ACCOUNT\n | I_DIP\n | I_DROP\n | I_DUP\n | I_VIEW\n | I_EDIV\n | I_EMPTY_BIG_MAP\n | I_EMPTY_MAP\n | I_EMPTY_SET\n | I_EQ\n | I_EXEC\n | I_APPLY\n | I_FAILWITH\n | I_GE\n | I_GET\n | I_GET_AND_UPDATE\n | I_GT\n | I_HASH_KEY\n | I_IF\n | I_IF_CONS\n | I_IF_LEFT\n | I_IF_NONE\n | I_INT\n | I_LAMBDA\n | I_LAMBDA_REC\n | I_LE\n | I_LEFT\n | I_LEVEL\n | I_LOOP\n | I_LSL\n | I_LSR\n | I_LT\n | I_MAP\n | I_MEM\n | I_MUL\n | I_NEG\n | I_NEQ\n | I_NIL\n | I_NONE\n | I_NOT\n | I_NOW\n | I_MIN_BLOCK_TIME\n | I_OR\n | I_PAIR\n | I_UNPAIR\n | I_PUSH\n | I_RIGHT\n | I_SIZE\n | I_SOME\n | I_SOURCE\n | I_SENDER\n | I_SELF\n | I_SELF_ADDRESS\n | I_SLICE\n | I_STEPS_TO_QUOTA\n | I_SUB\n | I_SUB_MUTEZ\n | I_SWAP\n | I_TRANSFER_TOKENS\n | I_SET_DELEGATE\n | I_UNIT\n | I_UPDATE\n | I_XOR\n | I_ITER\n | I_LOOP_LEFT\n | I_ADDRESS\n | I_CONTRACT\n | I_ISNAT\n | I_CAST\n | I_RENAME\n | I_SAPLING_EMPTY_STATE\n | I_SAPLING_VERIFY_UPDATE\n | I_DIG\n | I_DUG\n | I_NEVER\n | I_VOTING_POWER\n | I_TOTAL_VOTING_POWER\n | I_KECCAK\n | I_SHA3\n | I_PAIRING_CHECK\n | I_TICKET\n | I_TICKET_DEPRECATED\n | I_READ_TICKET\n | I_SPLIT_TICKET\n | I_JOIN_TICKETS\n | I_OPEN_CHEST\n | I_EMIT\n | I_BYTES\n | I_NAT\n | T_bool\n | T_contract\n | T_int\n | T_key\n | T_key_hash\n | T_lambda\n | T_list\n | T_map\n | T_big_map\n | T_nat\n | T_option\n | T_or\n | T_pair\n | T_set\n | T_signature\n | T_string\n | T_bytes\n | T_mutez\n | T_timestamp\n | T_unit\n | T_operation\n | T_address\n | T_tx_rollup_l2_address\n | T_sapling_transaction\n | T_sapling_transaction_deprecated\n | T_sapling_state\n | T_chain_id\n | T_never\n | T_bls12_381_g1\n | T_bls12_381_g2\n | T_bls12_381_fr\n | T_ticket\n | T_chest_key\n | T_chest\n (* See the interface of [Global_constants_storage]. *)\n | H_constant\n\n(** Auxiliary types for error documentation.\n All the prim constructor prefixes must match their namespace. *)\n\ntype namespace =\n | (* prefix \"T\" *) Type_namespace\n | (* prefix \"D\" *) Constant_namespace\n | (* prefix \"I\" *) Instr_namespace\n | (* prefix \"K\" *) Keyword_namespace\n (* The Constant Hash namespace is a singleton reserved\n for the constant keyword. Unlike other primitives,\n constants have no representation in the typed IR,\n being fully expanded away before typechecking. *)\n | (* prefix \"H\" *) Constant_hash_namespace\n\nval namespace : prim -> namespace\n\nval prim_encoding : prim Data_encoding.encoding\n\nval string_of_prim : prim -> string\n\nval prim_of_string : string -> prim tzresult\n\nval prims_of_strings :\n string Micheline.canonical -> prim Micheline.canonical tzresult\n\nval strings_of_prims : prim Micheline.canonical -> string Micheline.canonical\n\n(** The string corresponds to the constructor prefix from the given namespace\n (i.e. \"T\", \"D\", \"I\" or \"K\") *)\nval string_of_namespace : namespace -> string\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* Copyright (c) 2022 DaiLambda, Inc. <contact@dailambda,jp> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Micheline\n\ntype error += Unknown_primitive_name of string\n\ntype error += Invalid_case of string\n\ntype error +=\n | Invalid_primitive_name of\n string Micheline.canonical * Micheline.canonical_location\n\ntype prim =\n | K_parameter\n | K_storage\n | K_code\n | K_view\n | D_False\n | D_Elt\n | D_Left\n | D_None\n | D_Pair\n | D_Right\n | D_Some\n | D_True\n | D_Unit\n | D_Lambda_rec\n | I_PACK\n | I_UNPACK\n | I_BLAKE2B\n | I_SHA256\n | I_SHA512\n | I_ABS\n | I_ADD\n | I_AMOUNT\n | I_AND\n | I_BALANCE\n | I_CAR\n | I_CDR\n | I_CHAIN_ID\n | I_CHECK_SIGNATURE\n | I_COMPARE\n | I_CONCAT\n | I_CONS\n | I_CREATE_ACCOUNT\n | I_CREATE_CONTRACT\n | I_IMPLICIT_ACCOUNT\n | I_DIP\n | I_DROP\n | I_DUP\n | I_VIEW\n | I_EDIV\n | I_EMPTY_BIG_MAP\n | I_EMPTY_MAP\n | I_EMPTY_SET\n | I_EQ\n | I_EXEC\n | I_APPLY\n | I_FAILWITH\n | I_GE\n | I_GET\n | I_GET_AND_UPDATE\n | I_GT\n | I_HASH_KEY\n | I_IF\n | I_IF_CONS\n | I_IF_LEFT\n | I_IF_NONE\n | I_INT\n | I_LAMBDA\n | I_LAMBDA_REC\n | I_LE\n | I_LEFT\n | I_LEVEL\n | I_LOOP\n | I_LSL\n | I_LSR\n | I_LT\n | I_MAP\n | I_MEM\n | I_MUL\n | I_NEG\n | I_NEQ\n | I_NIL\n | I_NONE\n | I_NOT\n | I_NOW\n | I_MIN_BLOCK_TIME\n | I_OR\n | I_PAIR\n | I_UNPAIR\n | I_PUSH\n | I_RIGHT\n | I_SIZE\n | I_SOME\n | I_SOURCE\n | I_SENDER\n | I_SELF\n | I_SELF_ADDRESS\n | I_SLICE\n | I_STEPS_TO_QUOTA\n | I_SUB\n | I_SUB_MUTEZ\n | I_SWAP\n | I_TRANSFER_TOKENS\n | I_SET_DELEGATE\n | I_UNIT\n | I_UPDATE\n | I_XOR\n | I_ITER\n | I_LOOP_LEFT\n | I_ADDRESS\n | I_CONTRACT\n | I_ISNAT\n | I_CAST\n | I_RENAME\n | I_SAPLING_EMPTY_STATE\n | I_SAPLING_VERIFY_UPDATE\n | I_DIG\n | I_DUG\n | I_NEVER\n | I_VOTING_POWER\n | I_TOTAL_VOTING_POWER\n | I_KECCAK\n | I_SHA3\n | I_PAIRING_CHECK\n | I_TICKET\n | I_TICKET_DEPRECATED\n | I_READ_TICKET\n | I_SPLIT_TICKET\n | I_JOIN_TICKETS\n | I_OPEN_CHEST\n | I_EMIT\n | I_BYTES\n | I_NAT\n | T_bool\n | T_contract\n | T_int\n | T_key\n | T_key_hash\n | T_lambda\n | T_list\n | T_map\n | T_big_map\n | T_nat\n | T_option\n | T_or\n | T_pair\n | T_set\n | T_signature\n | T_string\n | T_bytes\n | T_mutez\n | T_timestamp\n | T_unit\n | T_operation\n | T_address\n | T_tx_rollup_l2_address\n | T_sapling_transaction\n | T_sapling_transaction_deprecated\n | T_sapling_state\n | T_chain_id\n | T_never\n | T_bls12_381_g1\n | T_bls12_381_g2\n | T_bls12_381_fr\n | T_ticket\n | T_chest_key\n | T_chest\n | H_constant\n\n(* Auxiliary types for error documentation.\n All the prim constructor prefixes must match their namespace. *)\ntype namespace =\n | (* prefix \"T\" *) Type_namespace\n | (* prefix \"D\" *) Constant_namespace\n | (* prefix \"I\" *) Instr_namespace\n | (* prefix \"K\" *) Keyword_namespace\n | (* prefix \"H\" *) Constant_hash_namespace\n\nlet namespace = function\n | K_code | K_view | K_parameter | K_storage -> Keyword_namespace\n | D_Elt | D_False | D_Left | D_None | D_Pair | D_Right | D_Some | D_True\n | D_Unit | D_Lambda_rec ->\n Constant_namespace\n | I_ABS | I_ADD | I_ADDRESS | I_AMOUNT | I_AND | I_APPLY | I_BALANCE\n | I_BLAKE2B | I_CAR | I_CAST | I_CDR | I_CHAIN_ID | I_CHECK_SIGNATURE\n | I_COMPARE | I_CONCAT | I_CONS | I_CONTRACT | I_CREATE_ACCOUNT\n | I_CREATE_CONTRACT | I_DIG | I_DIP | I_DROP | I_DUG | I_DUP | I_VIEW | I_EDIV\n | I_EMPTY_BIG_MAP | I_EMPTY_MAP | I_EMPTY_SET | I_EQ | I_EXEC | I_FAILWITH\n | I_GE | I_GET | I_GET_AND_UPDATE | I_GT | I_HASH_KEY | I_IF | I_IF_CONS\n | I_IF_LEFT | I_IF_NONE | I_IMPLICIT_ACCOUNT | I_INT | I_ISNAT | I_ITER\n | I_JOIN_TICKETS | I_KECCAK | I_LAMBDA | I_LAMBDA_REC | I_LE | I_LEFT\n | I_LEVEL | I_LOOP | I_LOOP_LEFT | I_LSL | I_LSR | I_LT | I_MAP | I_MEM\n | I_MUL | I_NEG | I_NEQ | I_NEVER | I_NIL | I_NONE | I_NOT | I_NOW\n | I_MIN_BLOCK_TIME | I_OR | I_PACK | I_PAIR | I_PAIRING_CHECK | I_PUSH\n | I_READ_TICKET | I_RENAME | I_RIGHT | I_SAPLING_EMPTY_STATE\n | I_SAPLING_VERIFY_UPDATE | I_SELF | I_SELF_ADDRESS | I_SENDER\n | I_SET_DELEGATE | I_SHA256 | I_SHA512 | I_SHA3 | I_SIZE | I_SLICE | I_SOME\n | I_SOURCE | I_SPLIT_TICKET | I_STEPS_TO_QUOTA | I_SUB | I_SUB_MUTEZ | I_SWAP\n | I_TICKET | I_TICKET_DEPRECATED | I_TOTAL_VOTING_POWER | I_TRANSFER_TOKENS\n | I_UNIT | I_UNPACK | I_UNPAIR | I_UPDATE | I_VOTING_POWER | I_XOR\n | I_OPEN_CHEST | I_EMIT | I_BYTES | I_NAT ->\n Instr_namespace\n | T_address | T_tx_rollup_l2_address | T_big_map | T_bool | T_bytes\n | T_chain_id | T_contract | T_int | T_key | T_key_hash | T_lambda | T_list\n | T_map | T_mutez | T_nat | T_never | T_operation | T_option | T_or | T_pair\n | T_sapling_state | T_sapling_transaction | T_sapling_transaction_deprecated\n | T_set | T_signature | T_string | T_timestamp | T_unit | T_bls12_381_fr\n | T_bls12_381_g1 | T_bls12_381_g2 | T_ticket | T_chest_key | T_chest ->\n Type_namespace\n | H_constant -> Constant_hash_namespace\n\nlet valid_case name =\n let is_lower = function '_' | 'a' .. 'z' -> true | _ -> false in\n let is_upper = function '_' | 'A' .. 'Z' -> true | _ -> false in\n let rec for_all a b f = Compare.Int.(a > b) || (f a && for_all (a + 1) b f) in\n let len = String.length name in\n Compare.Int.(len <> 0)\n && Compare.Char.(name.[0] <> '_')\n && ((is_upper name.[0] && for_all 1 (len - 1) (fun i -> is_upper name.[i]))\n || (is_upper name.[0] && for_all 1 (len - 1) (fun i -> is_lower name.[i]))\n || (is_lower name.[0] && for_all 1 (len - 1) (fun i -> is_lower name.[i]))\n )\n\nlet string_of_prim = function\n | K_parameter -> \"parameter\"\n | K_storage -> \"storage\"\n | K_code -> \"code\"\n | K_view -> \"view\"\n | D_False -> \"False\"\n | D_Elt -> \"Elt\"\n | D_Left -> \"Left\"\n | D_None -> \"None\"\n | D_Pair -> \"Pair\"\n | D_Right -> \"Right\"\n | D_Some -> \"Some\"\n | D_True -> \"True\"\n | D_Unit -> \"Unit\"\n | D_Lambda_rec -> \"Lambda_rec\"\n | I_PACK -> \"PACK\"\n | I_UNPACK -> \"UNPACK\"\n | I_BLAKE2B -> \"BLAKE2B\"\n | I_SHA256 -> \"SHA256\"\n | I_SHA512 -> \"SHA512\"\n | I_ABS -> \"ABS\"\n | I_ADD -> \"ADD\"\n | I_AMOUNT -> \"AMOUNT\"\n | I_AND -> \"AND\"\n | I_BALANCE -> \"BALANCE\"\n | I_CAR -> \"CAR\"\n | I_CDR -> \"CDR\"\n | I_CHAIN_ID -> \"CHAIN_ID\"\n | I_CHECK_SIGNATURE -> \"CHECK_SIGNATURE\"\n | I_COMPARE -> \"COMPARE\"\n | I_CONCAT -> \"CONCAT\"\n | I_CONS -> \"CONS\"\n | I_CREATE_ACCOUNT -> \"CREATE_ACCOUNT\"\n | I_CREATE_CONTRACT -> \"CREATE_CONTRACT\"\n | I_IMPLICIT_ACCOUNT -> \"IMPLICIT_ACCOUNT\"\n | I_DIP -> \"DIP\"\n | I_DROP -> \"DROP\"\n | I_DUP -> \"DUP\"\n | I_EDIV -> \"EDIV\"\n | I_EMPTY_BIG_MAP -> \"EMPTY_BIG_MAP\"\n | I_EMPTY_MAP -> \"EMPTY_MAP\"\n | I_EMPTY_SET -> \"EMPTY_SET\"\n | I_EQ -> \"EQ\"\n | I_EXEC -> \"EXEC\"\n | I_APPLY -> \"APPLY\"\n | I_FAILWITH -> \"FAILWITH\"\n | I_GE -> \"GE\"\n | I_GET -> \"GET\"\n | I_GET_AND_UPDATE -> \"GET_AND_UPDATE\"\n | I_GT -> \"GT\"\n | I_HASH_KEY -> \"HASH_KEY\"\n | I_IF -> \"IF\"\n | I_IF_CONS -> \"IF_CONS\"\n | I_IF_LEFT -> \"IF_LEFT\"\n | I_IF_NONE -> \"IF_NONE\"\n | I_INT -> \"INT\"\n | I_LAMBDA -> \"LAMBDA\"\n | I_LAMBDA_REC -> \"LAMBDA_REC\"\n | I_LE -> \"LE\"\n | I_LEFT -> \"LEFT\"\n | I_LEVEL -> \"LEVEL\"\n | I_LOOP -> \"LOOP\"\n | I_LSL -> \"LSL\"\n | I_LSR -> \"LSR\"\n | I_LT -> \"LT\"\n | I_MAP -> \"MAP\"\n | I_MEM -> \"MEM\"\n | I_MUL -> \"MUL\"\n | I_NEG -> \"NEG\"\n | I_NEQ -> \"NEQ\"\n | I_NIL -> \"NIL\"\n | I_NONE -> \"NONE\"\n | I_NOT -> \"NOT\"\n | I_NOW -> \"NOW\"\n | I_MIN_BLOCK_TIME -> \"MIN_BLOCK_TIME\"\n | I_OR -> \"OR\"\n | I_PAIR -> \"PAIR\"\n | I_PUSH -> \"PUSH\"\n | I_RIGHT -> \"RIGHT\"\n | I_SIZE -> \"SIZE\"\n | I_SOME -> \"SOME\"\n | I_SOURCE -> \"SOURCE\"\n | I_SENDER -> \"SENDER\"\n | I_SELF -> \"SELF\"\n | I_SELF_ADDRESS -> \"SELF_ADDRESS\"\n | I_SLICE -> \"SLICE\"\n | I_STEPS_TO_QUOTA -> \"STEPS_TO_QUOTA\"\n | I_SUB -> \"SUB\"\n | I_SUB_MUTEZ -> \"SUB_MUTEZ\"\n | I_SWAP -> \"SWAP\"\n | I_TRANSFER_TOKENS -> \"TRANSFER_TOKENS\"\n | I_SET_DELEGATE -> \"SET_DELEGATE\"\n | I_UNIT -> \"UNIT\"\n | I_UNPAIR -> \"UNPAIR\"\n | I_UPDATE -> \"UPDATE\"\n | I_XOR -> \"XOR\"\n | I_ITER -> \"ITER\"\n | I_LOOP_LEFT -> \"LOOP_LEFT\"\n | I_ADDRESS -> \"ADDRESS\"\n | I_CONTRACT -> \"CONTRACT\"\n | I_ISNAT -> \"ISNAT\"\n | I_CAST -> \"CAST\"\n | I_RENAME -> \"RENAME\"\n | I_SAPLING_EMPTY_STATE -> \"SAPLING_EMPTY_STATE\"\n | I_SAPLING_VERIFY_UPDATE -> \"SAPLING_VERIFY_UPDATE\"\n | I_DIG -> \"DIG\"\n | I_DUG -> \"DUG\"\n | I_NEVER -> \"NEVER\"\n | I_VOTING_POWER -> \"VOTING_POWER\"\n | I_TOTAL_VOTING_POWER -> \"TOTAL_VOTING_POWER\"\n | I_KECCAK -> \"KECCAK\"\n | I_SHA3 -> \"SHA3\"\n | I_PAIRING_CHECK -> \"PAIRING_CHECK\"\n | I_TICKET -> \"TICKET\"\n | I_TICKET_DEPRECATED -> \"TICKET_DEPRECATED\"\n | I_READ_TICKET -> \"READ_TICKET\"\n | I_SPLIT_TICKET -> \"SPLIT_TICKET\"\n | I_JOIN_TICKETS -> \"JOIN_TICKETS\"\n | I_OPEN_CHEST -> \"OPEN_CHEST\"\n | I_EMIT -> \"EMIT\"\n | I_VIEW -> \"VIEW\"\n | I_BYTES -> \"BYTES\"\n | I_NAT -> \"NAT\"\n | T_bool -> \"bool\"\n | T_contract -> \"contract\"\n | T_int -> \"int\"\n | T_key -> \"key\"\n | T_key_hash -> \"key_hash\"\n | T_lambda -> \"lambda\"\n | T_list -> \"list\"\n | T_map -> \"map\"\n | T_big_map -> \"big_map\"\n | T_nat -> \"nat\"\n | T_option -> \"option\"\n | T_or -> \"or\"\n | T_pair -> \"pair\"\n | T_set -> \"set\"\n | T_signature -> \"signature\"\n | T_string -> \"string\"\n | T_bytes -> \"bytes\"\n | T_mutez -> \"mutez\"\n | T_timestamp -> \"timestamp\"\n | T_unit -> \"unit\"\n | T_operation -> \"operation\"\n | T_address -> \"address\"\n | T_tx_rollup_l2_address -> \"tx_rollup_l2_address\"\n | T_sapling_state -> \"sapling_state\"\n | T_sapling_transaction -> \"sapling_transaction\"\n | T_sapling_transaction_deprecated -> \"sapling_transaction_deprecated\"\n | T_chain_id -> \"chain_id\"\n | T_never -> \"never\"\n | T_bls12_381_g1 -> \"bls12_381_g1\"\n | T_bls12_381_g2 -> \"bls12_381_g2\"\n | T_bls12_381_fr -> \"bls12_381_fr\"\n | T_ticket -> \"ticket\"\n | T_chest_key -> \"chest_key\"\n | T_chest -> \"chest\"\n | H_constant -> \"constant\"\n\nlet prim_of_string = function\n | \"parameter\" -> ok K_parameter\n | \"storage\" -> ok K_storage\n | \"code\" -> ok K_code\n | \"view\" -> ok K_view\n | \"False\" -> ok D_False\n | \"Elt\" -> ok D_Elt\n | \"Left\" -> ok D_Left\n | \"None\" -> ok D_None\n | \"Pair\" -> ok D_Pair\n | \"Right\" -> ok D_Right\n | \"Some\" -> ok D_Some\n | \"True\" -> ok D_True\n | \"Unit\" -> ok D_Unit\n | \"Lambda_rec\" -> ok D_Lambda_rec\n | \"PACK\" -> ok I_PACK\n | \"UNPACK\" -> ok I_UNPACK\n | \"BLAKE2B\" -> ok I_BLAKE2B\n | \"SHA256\" -> ok I_SHA256\n | \"SHA512\" -> ok I_SHA512\n | \"ABS\" -> ok I_ABS\n | \"ADD\" -> ok I_ADD\n | \"AMOUNT\" -> ok I_AMOUNT\n | \"AND\" -> ok I_AND\n | \"BALANCE\" -> ok I_BALANCE\n | \"CAR\" -> ok I_CAR\n | \"CDR\" -> ok I_CDR\n | \"CHAIN_ID\" -> ok I_CHAIN_ID\n | \"CHECK_SIGNATURE\" -> ok I_CHECK_SIGNATURE\n | \"COMPARE\" -> ok I_COMPARE\n | \"CONCAT\" -> ok I_CONCAT\n | \"CONS\" -> ok I_CONS\n | \"CREATE_ACCOUNT\" -> ok I_CREATE_ACCOUNT\n | \"CREATE_CONTRACT\" -> ok I_CREATE_CONTRACT\n | \"IMPLICIT_ACCOUNT\" -> ok I_IMPLICIT_ACCOUNT\n | \"DIP\" -> ok I_DIP\n | \"DROP\" -> ok I_DROP\n | \"DUP\" -> ok I_DUP\n | \"VIEW\" -> ok I_VIEW\n | \"EDIV\" -> ok I_EDIV\n | \"EMPTY_BIG_MAP\" -> ok I_EMPTY_BIG_MAP\n | \"EMPTY_MAP\" -> ok I_EMPTY_MAP\n | \"EMPTY_SET\" -> ok I_EMPTY_SET\n | \"EQ\" -> ok I_EQ\n | \"EXEC\" -> ok I_EXEC\n | \"APPLY\" -> ok I_APPLY\n | \"FAILWITH\" -> ok I_FAILWITH\n | \"GE\" -> ok I_GE\n | \"GET\" -> ok I_GET\n | \"GET_AND_UPDATE\" -> ok I_GET_AND_UPDATE\n | \"GT\" -> ok I_GT\n | \"HASH_KEY\" -> ok I_HASH_KEY\n | \"IF\" -> ok I_IF\n | \"IF_CONS\" -> ok I_IF_CONS\n | \"IF_LEFT\" -> ok I_IF_LEFT\n | \"IF_NONE\" -> ok I_IF_NONE\n | \"INT\" -> ok I_INT\n | \"KECCAK\" -> ok I_KECCAK\n | \"LAMBDA\" -> ok I_LAMBDA\n | \"LAMBDA_REC\" -> ok I_LAMBDA_REC\n | \"LE\" -> ok I_LE\n | \"LEFT\" -> ok I_LEFT\n | \"LEVEL\" -> ok I_LEVEL\n | \"LOOP\" -> ok I_LOOP\n | \"LSL\" -> ok I_LSL\n | \"LSR\" -> ok I_LSR\n | \"LT\" -> ok I_LT\n | \"MAP\" -> ok I_MAP\n | \"MEM\" -> ok I_MEM\n | \"MUL\" -> ok I_MUL\n | \"NEG\" -> ok I_NEG\n | \"NEQ\" -> ok I_NEQ\n | \"NIL\" -> ok I_NIL\n | \"NONE\" -> ok I_NONE\n | \"NOT\" -> ok I_NOT\n | \"NOW\" -> ok I_NOW\n | \"MIN_BLOCK_TIME\" -> ok I_MIN_BLOCK_TIME\n | \"OR\" -> ok I_OR\n | \"PAIR\" -> ok I_PAIR\n | \"UNPAIR\" -> ok I_UNPAIR\n | \"PAIRING_CHECK\" -> ok I_PAIRING_CHECK\n | \"PUSH\" -> ok I_PUSH\n | \"RIGHT\" -> ok I_RIGHT\n | \"SHA3\" -> ok I_SHA3\n | \"SIZE\" -> ok I_SIZE\n | \"SOME\" -> ok I_SOME\n | \"SOURCE\" -> ok I_SOURCE\n | \"SENDER\" -> ok I_SENDER\n | \"SELF\" -> ok I_SELF\n | \"SELF_ADDRESS\" -> ok I_SELF_ADDRESS\n | \"SLICE\" -> ok I_SLICE\n | \"STEPS_TO_QUOTA\" -> ok I_STEPS_TO_QUOTA\n | \"SUB\" -> ok I_SUB\n | \"SUB_MUTEZ\" -> ok I_SUB_MUTEZ\n | \"SWAP\" -> ok I_SWAP\n | \"TRANSFER_TOKENS\" -> ok I_TRANSFER_TOKENS\n | \"SET_DELEGATE\" -> ok I_SET_DELEGATE\n | \"UNIT\" -> ok I_UNIT\n | \"UPDATE\" -> ok I_UPDATE\n | \"XOR\" -> ok I_XOR\n | \"ITER\" -> ok I_ITER\n | \"LOOP_LEFT\" -> ok I_LOOP_LEFT\n | \"ADDRESS\" -> ok I_ADDRESS\n | \"CONTRACT\" -> ok I_CONTRACT\n | \"ISNAT\" -> ok I_ISNAT\n | \"CAST\" -> ok I_CAST\n | \"RENAME\" -> ok I_RENAME\n | \"SAPLING_EMPTY_STATE\" -> ok I_SAPLING_EMPTY_STATE\n | \"SAPLING_VERIFY_UPDATE\" -> ok I_SAPLING_VERIFY_UPDATE\n | \"DIG\" -> ok I_DIG\n | \"DUG\" -> ok I_DUG\n | \"NEVER\" -> ok I_NEVER\n | \"VOTING_POWER\" -> ok I_VOTING_POWER\n | \"TOTAL_VOTING_POWER\" -> ok I_TOTAL_VOTING_POWER\n | \"TICKET\" -> ok I_TICKET\n | \"TICKET_DEPRECATED\" -> ok I_TICKET_DEPRECATED\n | \"READ_TICKET\" -> ok I_READ_TICKET\n | \"SPLIT_TICKET\" -> ok I_SPLIT_TICKET\n | \"JOIN_TICKETS\" -> ok I_JOIN_TICKETS\n | \"OPEN_CHEST\" -> ok I_OPEN_CHEST\n | \"EMIT\" -> ok I_EMIT\n | \"BYTES\" -> ok I_BYTES\n | \"NAT\" -> ok I_NAT\n | \"bool\" -> ok T_bool\n | \"contract\" -> ok T_contract\n | \"int\" -> ok T_int\n | \"key\" -> ok T_key\n | \"key_hash\" -> ok T_key_hash\n | \"lambda\" -> ok T_lambda\n | \"list\" -> ok T_list\n | \"map\" -> ok T_map\n | \"big_map\" -> ok T_big_map\n | \"nat\" -> ok T_nat\n | \"option\" -> ok T_option\n | \"or\" -> ok T_or\n | \"pair\" -> ok T_pair\n | \"set\" -> ok T_set\n | \"signature\" -> ok T_signature\n | \"string\" -> ok T_string\n | \"bytes\" -> ok T_bytes\n | \"mutez\" -> ok T_mutez\n | \"timestamp\" -> ok T_timestamp\n | \"unit\" -> ok T_unit\n | \"operation\" -> ok T_operation\n | \"address\" -> ok T_address\n | \"tx_rollup_l2_address\" -> ok T_tx_rollup_l2_address\n | \"sapling_state\" -> ok T_sapling_state\n | \"sapling_transaction\" -> ok T_sapling_transaction\n | \"sapling_transaction_deprecated\" -> ok T_sapling_transaction_deprecated\n | \"chain_id\" -> ok T_chain_id\n | \"never\" -> ok T_never\n | \"bls12_381_g1\" -> ok T_bls12_381_g1\n | \"bls12_381_g2\" -> ok T_bls12_381_g2\n | \"bls12_381_fr\" -> ok T_bls12_381_fr\n | \"ticket\" -> ok T_ticket\n | \"chest_key\" -> ok T_chest_key\n | \"chest\" -> ok T_chest\n | \"constant\" -> ok H_constant\n | n ->\n if valid_case n then error (Unknown_primitive_name n)\n else error (Invalid_case n)\n\nlet prims_of_strings expr =\n let rec convert = function\n | (Int _ | String _ | Bytes _) as expr -> ok expr\n | Prim (loc, prim, args, annot) ->\n Error_monad.record_trace\n (Invalid_primitive_name (expr, loc))\n (prim_of_string prim)\n >>? fun prim ->\n List.map_e convert args >|? fun args -> Prim (loc, prim, args, annot)\n | Seq (loc, args) -> List.map_e convert args >|? fun args -> Seq (loc, args)\n in\n convert (root expr) >|? fun expr -> strip_locations expr\n\nlet strings_of_prims expr =\n let rec convert = function\n | (Int _ | String _ | Bytes _) as expr -> expr\n | Prim (loc, prim, args, annot) ->\n let prim = string_of_prim prim in\n let args = List.map convert args in\n Prim (loc, prim, args, annot)\n | Seq (loc, args) ->\n let args = List.map convert args in\n Seq (loc, args)\n in\n strip_locations (convert (root expr))\n\nlet prim_encoding =\n let open Data_encoding in\n def \"michelson.v1.primitives\"\n @@ string_enum\n (* Add the comment below every 10 lines *)\n [\n (* /!\\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)\n (\"parameter\", K_parameter);\n (\"storage\", K_storage);\n (\"code\", K_code);\n (\"False\", D_False);\n (\"Elt\", D_Elt);\n (\"Left\", D_Left);\n (\"None\", D_None);\n (\"Pair\", D_Pair);\n (\"Right\", D_Right);\n (\"Some\", D_Some);\n (* /!\\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)\n (\"True\", D_True);\n (\"Unit\", D_Unit);\n (\"PACK\", I_PACK);\n (\"UNPACK\", I_UNPACK);\n (\"BLAKE2B\", I_BLAKE2B);\n (\"SHA256\", I_SHA256);\n (\"SHA512\", I_SHA512);\n (\"ABS\", I_ABS);\n (\"ADD\", I_ADD);\n (\"AMOUNT\", I_AMOUNT);\n (* /!\\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)\n (\"AND\", I_AND);\n (\"BALANCE\", I_BALANCE);\n (\"CAR\", I_CAR);\n (\"CDR\", I_CDR);\n (\"CHECK_SIGNATURE\", I_CHECK_SIGNATURE);\n (\"COMPARE\", I_COMPARE);\n (\"CONCAT\", I_CONCAT);\n (\"CONS\", I_CONS);\n (\"CREATE_ACCOUNT\", I_CREATE_ACCOUNT);\n (\"CREATE_CONTRACT\", I_CREATE_CONTRACT);\n (* /!\\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)\n (\"IMPLICIT_ACCOUNT\", I_IMPLICIT_ACCOUNT);\n (\"DIP\", I_DIP);\n (\"DROP\", I_DROP);\n (\"DUP\", I_DUP);\n (\"EDIV\", I_EDIV);\n (\"EMPTY_MAP\", I_EMPTY_MAP);\n (\"EMPTY_SET\", I_EMPTY_SET);\n (\"EQ\", I_EQ);\n (\"EXEC\", I_EXEC);\n (\"FAILWITH\", I_FAILWITH);\n (* /!\\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)\n (\"GE\", I_GE);\n (\"GET\", I_GET);\n (\"GT\", I_GT);\n (\"HASH_KEY\", I_HASH_KEY);\n (\"IF\", I_IF);\n (\"IF_CONS\", I_IF_CONS);\n (\"IF_LEFT\", I_IF_LEFT);\n (\"IF_NONE\", I_IF_NONE);\n (\"INT\", I_INT);\n (\"LAMBDA\", I_LAMBDA);\n (* /!\\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)\n (\"LE\", I_LE);\n (\"LEFT\", I_LEFT);\n (\"LOOP\", I_LOOP);\n (\"LSL\", I_LSL);\n (\"LSR\", I_LSR);\n (\"LT\", I_LT);\n (\"MAP\", I_MAP);\n (\"MEM\", I_MEM);\n (\"MUL\", I_MUL);\n (\"NEG\", I_NEG);\n (* /!\\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)\n (\"NEQ\", I_NEQ);\n (\"NIL\", I_NIL);\n (\"NONE\", I_NONE);\n (\"NOT\", I_NOT);\n (\"NOW\", I_NOW);\n (\"OR\", I_OR);\n (\"PAIR\", I_PAIR);\n (\"PUSH\", I_PUSH);\n (\"RIGHT\", I_RIGHT);\n (\"SIZE\", I_SIZE);\n (* /!\\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)\n (\"SOME\", I_SOME);\n (\"SOURCE\", I_SOURCE);\n (\"SENDER\", I_SENDER);\n (\"SELF\", I_SELF);\n (\"STEPS_TO_QUOTA\", I_STEPS_TO_QUOTA);\n (\"SUB\", I_SUB);\n (\"SWAP\", I_SWAP);\n (\"TRANSFER_TOKENS\", I_TRANSFER_TOKENS);\n (\"SET_DELEGATE\", I_SET_DELEGATE);\n (\"UNIT\", I_UNIT);\n (* /!\\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)\n (\"UPDATE\", I_UPDATE);\n (\"XOR\", I_XOR);\n (\"ITER\", I_ITER);\n (\"LOOP_LEFT\", I_LOOP_LEFT);\n (\"ADDRESS\", I_ADDRESS);\n (\"CONTRACT\", I_CONTRACT);\n (\"ISNAT\", I_ISNAT);\n (\"CAST\", I_CAST);\n (\"RENAME\", I_RENAME);\n (\"bool\", T_bool);\n (* /!\\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)\n (\"contract\", T_contract);\n (\"int\", T_int);\n (\"key\", T_key);\n (\"key_hash\", T_key_hash);\n (\"lambda\", T_lambda);\n (\"list\", T_list);\n (\"map\", T_map);\n (\"big_map\", T_big_map);\n (\"nat\", T_nat);\n (\"option\", T_option);\n (* /!\\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)\n (\"or\", T_or);\n (\"pair\", T_pair);\n (\"set\", T_set);\n (\"signature\", T_signature);\n (\"string\", T_string);\n (\"bytes\", T_bytes);\n (\"mutez\", T_mutez);\n (\"timestamp\", T_timestamp);\n (\"unit\", T_unit);\n (\"operation\", T_operation);\n (* /!\\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)\n (\"address\", T_address);\n (* Alpha_002 addition *)\n (\"SLICE\", I_SLICE);\n (* Alpha_005 addition *)\n (\"DIG\", I_DIG);\n (\"DUG\", I_DUG);\n (\"EMPTY_BIG_MAP\", I_EMPTY_BIG_MAP);\n (\"APPLY\", I_APPLY);\n (\"chain_id\", T_chain_id);\n (\"CHAIN_ID\", I_CHAIN_ID);\n (* /!\\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)\n (* Alpha_008 addition *)\n (\"LEVEL\", I_LEVEL);\n (\"SELF_ADDRESS\", I_SELF_ADDRESS);\n (\"never\", T_never);\n (\"NEVER\", I_NEVER);\n (\"UNPAIR\", I_UNPAIR);\n (\"VOTING_POWER\", I_VOTING_POWER);\n (\"TOTAL_VOTING_POWER\", I_TOTAL_VOTING_POWER);\n (\"KECCAK\", I_KECCAK);\n (\"SHA3\", I_SHA3);\n (* /!\\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)\n (* Alpha_008 addition *)\n (\"PAIRING_CHECK\", I_PAIRING_CHECK);\n (\"bls12_381_g1\", T_bls12_381_g1);\n (\"bls12_381_g2\", T_bls12_381_g2);\n (\"bls12_381_fr\", T_bls12_381_fr);\n (\"sapling_state\", T_sapling_state);\n (\"sapling_transaction_deprecated\", T_sapling_transaction_deprecated);\n (\"SAPLING_EMPTY_STATE\", I_SAPLING_EMPTY_STATE);\n (\"SAPLING_VERIFY_UPDATE\", I_SAPLING_VERIFY_UPDATE);\n (\"ticket\", T_ticket);\n (* /!\\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)\n (* Alpha_008 addition *)\n (\"TICKET_DEPRECATED\", I_TICKET_DEPRECATED);\n (\"READ_TICKET\", I_READ_TICKET);\n (\"SPLIT_TICKET\", I_SPLIT_TICKET);\n (\"JOIN_TICKETS\", I_JOIN_TICKETS);\n (\"GET_AND_UPDATE\", I_GET_AND_UPDATE);\n (* Alpha_011 addition *)\n (\"chest\", T_chest);\n (\"chest_key\", T_chest_key);\n (\"OPEN_CHEST\", I_OPEN_CHEST);\n (* /!\\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)\n (\"VIEW\", I_VIEW);\n (\"view\", K_view);\n (\"constant\", H_constant);\n (* Alpha_012 addition *)\n (\"SUB_MUTEZ\", I_SUB_MUTEZ);\n (* Alpha_013 addition *)\n (\"tx_rollup_l2_address\", T_tx_rollup_l2_address);\n (\"MIN_BLOCK_TIME\", I_MIN_BLOCK_TIME);\n (\"sapling_transaction\", T_sapling_transaction);\n (* /!\\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)\n (* Alpha_014 addition *)\n (\"EMIT\", I_EMIT);\n (* Alpha_015 addition *)\n (\"Lambda_rec\", D_Lambda_rec);\n (\"LAMBDA_REC\", I_LAMBDA_REC);\n (\"TICKET\", I_TICKET);\n (\"BYTES\", I_BYTES);\n (\"NAT\", I_NAT)\n (* New instructions must be added here, for backward compatibility of the encoding. *)\n (* Keep the comment above at the end of the list *);\n ]\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.unknown_primitive_name\"\n ~title:\"Unknown primitive name\"\n ~description:\"In a script or data expression, a primitive was unknown.\"\n ~pp:(fun ppf n -> Format.fprintf ppf \"Unknown primitive %s.\" n)\n Data_encoding.(obj1 (req \"wrong_primitive_name\" @@ string Plain))\n (function Unknown_primitive_name got -> Some got | _ -> None)\n (fun got -> Unknown_primitive_name got) ;\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.invalid_primitive_name_case\"\n ~title:\"Invalid primitive name case\"\n ~description:\n \"In a script or data expression, a primitive name is neither uppercase, \\\n lowercase or capitalized.\"\n ~pp:(fun ppf n -> Format.fprintf ppf \"Primitive %s has invalid case.\" n)\n Data_encoding.(obj1 (req \"wrong_primitive_name\" @@ string Plain))\n (function Invalid_case name -> Some name | _ -> None)\n (fun name -> Invalid_case name) ;\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.invalid_primitive_name\"\n ~title:\"Invalid primitive name\"\n ~description:\n \"In a script or data expression, a primitive name is unknown or has a \\\n wrong case.\"\n ~pp:(fun ppf _ -> Format.fprintf ppf \"Invalid primitive.\")\n Data_encoding.(\n obj2\n (req\n \"expression\"\n (Micheline.canonical_encoding ~variant:\"generic\" @@ string Plain))\n (req \"location\" Micheline.canonical_location_encoding))\n (function\n | Invalid_primitive_name (expr, loc) -> Some (expr, loc) | _ -> None)\n (fun (expr, loc) -> Invalid_primitive_name (expr, loc))\n\nlet string_of_namespace = function\n | Type_namespace -> \"T\"\n | Constant_namespace -> \"D\"\n | Instr_namespace -> \"I\"\n | Keyword_namespace -> \"K\"\n | Constant_hash_namespace -> \"H\"\n" ;
} ;
{ name = "Slot_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Slot index representation *)\n\n(** {1 Abstract type} *)\n\n(** A slot index is in essence a bounded whole number. That is, it is not\n allowed to overflow [max_value], nor does it wrap when calling [succ\n max_value]. In this case it returns an [Invalid_slot] error.*)\ntype t\n\ntype slot = t\n\nval encoding : t Data_encoding.t\n\n(** {1 Constructors }*)\n\nval zero : t\n\n(** Upper bound on the value a slot index can take *)\nval max_value : t\n\n(** [of_int i] creates a slot index from integer [i].\n\n @return [Error (Invalid_slot i)] if [i < 0 || i > max_value], and\n [Ok slot] otherwise\n *)\nval of_int : int -> t tzresult\n\n(** [of_int_do_not_use_except_for_parameters i] is an unchecked construction\n function.\n\n It may be used in cases where one knows [0 <= i <= max_value], e.g., when\n creating protocol parameters.\n\n When in doubt, use [of_int] or [of_int_exn].\n *)\nval of_int_do_not_use_except_for_parameters : int -> t\n\n(** {1 Operator and pretty-printer} *)\n\n(** [succ n] either returns an [Invalid_slot] error if [n] is [max_value] or [ok\n value] otherwise. *)\nval succ : t -> t tzresult\n\n(** {1 Conversion/Printing} *)\n\n(** [to_int slot] returns the integral representation of a slot index. This\n value is always a whole number. *)\nval to_int : t -> int\n\nval pp : Format.formatter -> t -> unit\n\n(** {1 Submodules} *)\n\nmodule Map : Map.S with type key = t\n\nmodule Set : Set.S with type elt = t\n\ninclude Compare.S with type t := t\n\n(** {2 Slot ranges} *)\nmodule Range : sig\n (** An ordered range of slots, in increasing order. *)\n type t\n\n (** {3 Constructor} *)\n\n (** [create ~min ~count] creates a full slot range starting at [min], of size\n [count], i.e, [min, min + count - 1].\n\n [create] errors if\n - [min < 0]\n - [count < 1]\n - [min + count - 1 > max_value]\n *)\n val create : min:int -> count:int -> t tzresult\n\n (** {3 Iterators} *)\n\n (** [fold f acc range] folds [f] over the values of [range], in increasing\n order. *)\n val fold : ('a -> slot -> 'a) -> 'a -> t -> 'a\n\n (** [fold_es f acc range] folds [f] over the values of [range], in increasing\n order. *)\n val fold_es :\n ('a -> slot -> 'a tzresult Lwt.t) -> 'a -> t -> 'a tzresult Lwt.t\n\n (** [rev_fold_es f acc range] folds [f] over the values of [range], in decreasing\n order. *)\n val rev_fold_es :\n ('a -> slot -> 'a tzresult Lwt.t) -> 'a -> t -> 'a tzresult Lwt.t\nend\n\nmodule Internal_for_tests : sig\n val of_int : int -> t tzresult\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error += Invalid_slot of int\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"slot.invalid_slot\"\n ~title:\"invalid slot\"\n ~description:\"Invalid slot\"\n ~pp:(fun ppf x -> Format.fprintf ppf \"invalid slot: %d\" x)\n Data_encoding.(obj1 (req \"bad_slot\" int31))\n (function Invalid_slot x -> Some x | _ -> None)\n (fun x -> Invalid_slot x)\n\ninclude Compare.Int\n\ntype slot = t\n\n(* TODO? should there be some assertions to verify that slots are\n never too big ? Or do that in a storage module that depends on\n constants ? *)\n\nlet encoding = Data_encoding.uint16\n\nlet pp = Format.pp_print_int\n\nlet zero = 0\n\nlet to_int x = x\n\n(* We assume 2^16 slots is big enough.\n\n We could increase that, but we would need to make sure there is no big\n performance penalty first. *)\nlet max_value = (1 lsl 16) - 1\n\nlet of_int_do_not_use_except_for_parameters i = i\n\nlet of_int i =\n if Compare.Int.(i < 0 || i > max_value) then error (Invalid_slot i) else ok i\n\nlet succ slot = of_int (slot + 1)\n\nmodule Map = Map.Make (Compare.Int)\nmodule Set = Set.Make (Compare.Int)\n\nmodule Range = struct\n (* For now, we only need full intervals. If we ever need sparse ones, we\n could switch this representation to interval trees. [hi] and [lo] bounds\n are included. *)\n type t = Interval of {lo : int; hi : int}\n\n let create ~min ~count =\n error_when (min < 0) (Invalid_slot min) >>? fun () ->\n error_when (min > max_value) (Invalid_slot min) >>? fun () ->\n error_when (count < 1) (Invalid_slot count) >>? fun () ->\n error_when (count > max_value) (Invalid_slot count) >>? fun () ->\n let max = min + count - 1 in\n error_when (max > max_value) (Invalid_slot max) >>? fun () ->\n ok (Interval {lo = min; hi = max})\n\n let fold f init (Interval {lo; hi}) =\n let rec loop ~acc ~next =\n if Compare.Int.(next > hi) then acc\n else loop ~acc:(f acc next) ~next:(next + 1)\n in\n loop ~acc:(f init lo) ~next:(lo + 1)\n\n let fold_es f init (Interval {lo; hi}) =\n let rec loop ~acc ~next =\n if Compare.Int.(next > hi) then return acc\n else f acc next >>=? fun acc -> loop ~acc ~next:(next + 1)\n in\n f init lo >>=? fun acc -> loop ~acc ~next:(lo + 1)\n\n let rev_fold_es f init (Interval {lo; hi}) =\n let rec loop ~acc ~next =\n if Compare.Int.(next < lo) then return acc\n else f acc next >>=? fun acc -> loop ~acc ~next:(next - 1)\n in\n f init hi >>=? fun acc -> loop ~acc ~next:(hi - 1)\nend\n\nmodule Internal_for_tests = struct\n let of_int = of_int\nend\n" ;
} ;
{ name = "Tez_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Internal representation of the Tez currency. Behaves mostly like a natural\n number where number 1 represents 1/1,000,000 Tez (1 micro-Tez or mutez).\n It's protected from ever becoming negative and overflowing by special\n arithmetic functions, which fail in case something undesired would happen.\n When divided, it's always rounded down to 1 mutez.\n\n Internally encoded as [int64], which may be relevant to guard against\n overflow errors. *)\ntype repr\n\n(** [t] is made algebraic in order to distinguish it from the other type\n parameters of [Script_typed_ir.ty]. *)\ntype t = Tez_tag of repr [@@ocaml.unboxed]\n\ntype error += Subtraction_underflow of t * t (* `Temporary *)\n\ntype tez = t\n\nval zero : t\n\nval one_mutez : t\n\nval one_cent : t\n\nval fifty_cents : t\n\nval one : t\n\nval max_mutez : t\n\nval ( -? ) : t -> t -> t tzresult\n\n(** Same as ( -? ) but returns None instead of an error. *)\nval sub_opt : t -> t -> t option\n\nval ( +? ) : t -> t -> t tzresult\n\nval ( *? ) : t -> int64 -> t tzresult\n\nval ( /? ) : t -> int64 -> t tzresult\n\nval to_mutez : t -> int64\n\n(** [of_mutez n] (micro tez) is None if n is negative *)\nval of_mutez : int64 -> t option\n\n(** [of_mutez_exn n] fails if n is negative.\n It should only be used at toplevel for constants. *)\nval of_mutez_exn : int64 -> t\n\n(** It should only be used at toplevel for constants. *)\nval mul_exn : t -> int -> t\n\n(** It should only be used at toplevel for constants. *)\nval div_exn : t -> int -> t\n\nval encoding : t Data_encoding.t\n\ninclude Compare.S with type t := t\n\nval pp : Format.formatter -> t -> unit\n\nval of_string : string -> t option\n\nval to_string : t -> string\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nlet id = \"tez\"\n\nlet name = \"mutez\"\n\nopen Compare.Int64 (* invariant: positive *)\n\ntype repr = t\n\ntype t = Tez_tag of repr [@@ocaml.unboxed]\n\ntype error +=\n | Addition_overflow of t * t (* `Temporary *)\n | Subtraction_underflow of t * t (* `Temporary *)\n | Multiplication_overflow of t * int64 (* `Temporary *)\n | Negative_multiplicator of t * int64 (* `Temporary *)\n | Invalid_divisor of t * int64\n\n(* `Temporary *)\n\nlet zero = Tez_tag 0L\n\n(* all other constant are defined from the value of one micro tez *)\nlet one_mutez = Tez_tag 1L\n\nlet max_mutez = Tez_tag Int64.max_int\n\nlet mul_int (Tez_tag tez) i = Tez_tag (Int64.mul tez i)\n\nlet one_cent = mul_int one_mutez 10_000L\n\nlet fifty_cents = mul_int one_cent 50L\n\n(* 1 tez = 100 cents = 1_000_000 mutez *)\nlet one = mul_int one_cent 100L\n\nlet of_string s =\n let triplets = function\n | hd :: tl ->\n let len = String.length hd in\n Compare.Int.(\n len <= 3 && len > 0 && List.for_all (fun s -> String.length s = 3) tl)\n | [] -> false\n in\n let integers s = triplets (String.split_on_char ',' s) in\n let decimals s =\n let l = String.split_on_char ',' s in\n if Compare.List_length_with.(l > 2) then false else triplets (List.rev l)\n in\n let parse left right =\n let remove_commas s = String.concat \"\" (String.split_on_char ',' s) in\n let pad_to_six s =\n let len = String.length s in\n String.init 6 (fun i -> if Compare.Int.(i < len) then s.[i] else '0')\n in\n let prepared = remove_commas left ^ pad_to_six (remove_commas right) in\n Option.map (fun i -> Tez_tag i) (Int64.of_string_opt prepared)\n in\n match String.split_on_char '.' s with\n | [left; right] ->\n if String.contains s ',' then\n if integers left && decimals right then parse left right else None\n else if\n Compare.Int.(String.length right > 0)\n && Compare.Int.(String.length right <= 6)\n then parse left right\n else None\n | [left] ->\n if (not (String.contains s ',')) || integers left then parse left \"\"\n else None\n | _ -> None\n\nlet pp ppf (Tez_tag amount) =\n let mult_int = 1_000_000L in\n let rec left ppf amount =\n let d, r = (Int64.(div amount 1000L), Int64.(rem amount 1000L)) in\n if d > 0L then Format.fprintf ppf \"%a%03Ld\" left d r\n else Format.fprintf ppf \"%Ld\" r\n in\n let right ppf amount =\n let triplet ppf v =\n if Compare.Int.(v mod 10 > 0) then Format.fprintf ppf \"%03d\" v\n else if Compare.Int.(v mod 100 > 0) then Format.fprintf ppf \"%02d\" (v / 10)\n else Format.fprintf ppf \"%d\" (v / 100)\n in\n let hi, lo = (amount / 1000, amount mod 1000) in\n if Compare.Int.(lo = 0) then Format.fprintf ppf \"%a\" triplet hi\n else Format.fprintf ppf \"%03d%a\" hi triplet lo\n in\n let ints, decs =\n (Int64.(div amount mult_int), Int64.(to_int (rem amount mult_int)))\n in\n left ppf ints ;\n if Compare.Int.(decs > 0) then Format.fprintf ppf \".%a\" right decs\n\nlet to_string t = Format.asprintf \"%a\" pp t\n\nlet ( -? ) tez1 tez2 =\n let (Tez_tag t1) = tez1 in\n let (Tez_tag t2) = tez2 in\n if t2 <= t1 then ok (Tez_tag (Int64.sub t1 t2))\n else error (Subtraction_underflow (tez1, tez2))\n\nlet sub_opt (Tez_tag t1) (Tez_tag t2) =\n if t2 <= t1 then Some (Tez_tag (Int64.sub t1 t2)) else None\n\nlet ( +? ) tez1 tez2 =\n let (Tez_tag t1) = tez1 in\n let (Tez_tag t2) = tez2 in\n let t = Int64.add t1 t2 in\n if t < t1 then error (Addition_overflow (tez1, tez2)) else ok (Tez_tag t)\n\nlet ( *? ) tez m =\n let (Tez_tag t) = tez in\n if m < 0L then error (Negative_multiplicator (tez, m))\n else if m = 0L then ok (Tez_tag 0L)\n else if t > Int64.(div max_int m) then\n error (Multiplication_overflow (tez, m))\n else ok (Tez_tag (Int64.mul t m))\n\nlet ( /? ) tez d =\n let (Tez_tag t) = tez in\n if d <= 0L then error (Invalid_divisor (tez, d))\n else ok (Tez_tag (Int64.div t d))\n\nlet mul_exn t m =\n match t *? Int64.(of_int m) with\n | Ok v -> v\n | Error _ -> invalid_arg \"mul_exn\"\n\nlet div_exn t d =\n match t /? Int64.(of_int d) with\n | Ok v -> v\n | Error _ -> invalid_arg \"div_exn\"\n\nlet of_mutez t = if t < 0L then None else Some (Tez_tag t)\n\nlet of_mutez_exn x =\n match of_mutez x with None -> invalid_arg \"Tez.of_mutez\" | Some v -> v\n\nlet to_mutez (Tez_tag t) = t\n\nlet encoding =\n let open Data_encoding in\n let decode (Tez_tag t) = Z.of_int64 t in\n let encode = Json.wrap_error (fun i -> Tez_tag (Z.to_int64 i)) in\n Data_encoding.def name (check_size 10 (conv decode encode n))\n\nlet () =\n let open Data_encoding in\n register_error_kind\n `Temporary\n ~id:(id ^ \".addition_overflow\")\n ~title:(\"Overflowing \" ^ id ^ \" addition\")\n ~pp:(fun ppf (opa, opb) ->\n Format.fprintf\n ppf\n \"Overflowing addition of %a %s and %a %s\"\n pp\n opa\n id\n pp\n opb\n id)\n ~description:(\"An addition of two \" ^ id ^ \" amounts overflowed\")\n (obj1 (req \"amounts\" (tup2 encoding encoding)))\n (function Addition_overflow (a, b) -> Some (a, b) | _ -> None)\n (fun (a, b) -> Addition_overflow (a, b)) ;\n register_error_kind\n `Temporary\n ~id:(id ^ \".subtraction_underflow\")\n ~title:(\"Underflowing \" ^ id ^ \" subtraction\")\n ~pp:(fun ppf (opa, opb) ->\n Format.fprintf\n ppf\n \"Underflowing subtraction of %a %s and %a %s\"\n pp\n opa\n id\n pp\n opb\n id)\n ~description:\n (\"A subtraction of two \" ^ id\n ^ \" amounts underflowed (i.e., would have led to a negative amount)\")\n (obj1 (req \"amounts\" (tup2 encoding encoding)))\n (function Subtraction_underflow (a, b) -> Some (a, b) | _ -> None)\n (fun (a, b) -> Subtraction_underflow (a, b)) ;\n register_error_kind\n `Temporary\n ~id:(id ^ \".multiplication_overflow\")\n ~title:(\"Overflowing \" ^ id ^ \" multiplication\")\n ~pp:(fun ppf (opa, opb) ->\n Format.fprintf\n ppf\n \"Overflowing multiplication of %a %s and %Ld\"\n pp\n opa\n id\n opb)\n ~description:\n (\"A multiplication of a \" ^ id ^ \" amount by an integer overflowed\")\n (obj2 (req \"amount\" encoding) (req \"multiplicator\" int64))\n (function Multiplication_overflow (a, b) -> Some (a, b) | _ -> None)\n (fun (a, b) -> Multiplication_overflow (a, b)) ;\n register_error_kind\n `Temporary\n ~id:(id ^ \".negative_multiplicator\")\n ~title:(\"Negative \" ^ id ^ \" multiplicator\")\n ~pp:(fun ppf (opa, opb) ->\n Format.fprintf\n ppf\n \"Multiplication of %a %s by negative integer %Ld\"\n pp\n opa\n id\n opb)\n ~description:(\"Multiplication of a \" ^ id ^ \" amount by a negative integer\")\n (obj2 (req \"amount\" encoding) (req \"multiplicator\" int64))\n (function Negative_multiplicator (a, b) -> Some (a, b) | _ -> None)\n (fun (a, b) -> Negative_multiplicator (a, b)) ;\n register_error_kind\n `Temporary\n ~id:(id ^ \".invalid_divisor\")\n ~title:(\"Invalid \" ^ id ^ \" divisor\")\n ~pp:(fun ppf (opa, opb) ->\n Format.fprintf\n ppf\n \"Division of %a %s by non positive integer %Ld\"\n pp\n opa\n id\n opb)\n ~description:\n (\"Multiplication of a \" ^ id ^ \" amount by a non positive integer\")\n (obj2 (req \"amount\" encoding) (req \"divisor\" int64))\n (function Invalid_divisor (a, b) -> Some (a, b) | _ -> None)\n (fun (a, b) -> Invalid_divisor (a, b))\n\ntype tez = t\n\nlet compare (Tez_tag x) (Tez_tag y) = compare x y\n\nlet ( = ) (Tez_tag x) (Tez_tag y) = x = y\n\nlet ( <> ) (Tez_tag x) (Tez_tag y) = x <> y\n\nlet ( < ) (Tez_tag x) (Tez_tag y) = x < y\n\nlet ( > ) (Tez_tag x) (Tez_tag y) = x > y\n\nlet ( <= ) (Tez_tag x) (Tez_tag y) = x <= y\n\nlet ( >= ) (Tez_tag x) (Tez_tag y) = x >= y\n\nlet equal (Tez_tag x) (Tez_tag y) = equal x y\n\nlet max (Tez_tag x) (Tez_tag y) = Tez_tag (max x y)\n\nlet min (Tez_tag x) (Tez_tag y) = Tez_tag (min x y)\n" ;
} ;
{ name = "Period_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t\n\n(** Represents a period of time as a non-negative integer. *)\ntype period = t\n\ninclude Compare.S with type t := t\n\nval encoding : period Data_encoding.t\n\nval rpc_arg : period RPC_arg.t\n\nval pp : Format.formatter -> period -> unit\n\n(** Returns the number of seconds contained in the period. *)\nval to_seconds : period -> int64\n\n(** Converts a number of seconds to a [period].\n\n [of_second s] fails if [s] is not positive. *)\nval of_seconds : int64 -> period tzresult\n\n(** Converts a number of seconds to [period].\n\n [of_second s] fails if [s] is not positive.\n It should only be used at toplevel for constants. *)\nval of_seconds_exn : int64 -> period\n\n(** Safe addition of periods, guarded against overflow. *)\nval add : period -> period -> period tzresult\n\n(** Alias for [add]. *)\nval ( +? ) : period -> period -> period tzresult\n\n(** Safe multiplication by a positive integer. Guarded against overflow. *)\nval mult : int32 -> period -> period tzresult\n\nval zero : period\n\nval one_second : period\n\nval one_minute : period\n\nval one_hour : period\n\n(** [compare x y] returns [0] if [x] is equal to [y], a negative\n integer if [x] is shorter than [y], and a positive integer if [x]\n is longer than [y]. *)\nval compare : period -> period -> int\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(* `Permanent *)\ntype error += Malformed_period of int64 | Invalid_arg | Period_overflow\n\nlet () =\n let open Data_encoding in\n (* Malformed period *)\n register_error_kind\n `Permanent\n ~id:\"malformed_period\"\n ~title:\"Malformed period\"\n ~description:\"Period is negative.\"\n ~pp:(fun ppf period ->\n Format.fprintf ppf \"The given period '%Ld' is negative \" period)\n (obj1 (req \"malformed_period\" int64))\n (function Malformed_period n -> Some n | _ -> None)\n (fun n -> Malformed_period n) ;\n (* Invalid arg *)\n register_error_kind\n `Permanent\n ~id:\"invalid_arg\"\n ~title:\"Invalid arg\"\n ~description:\"Negative multiple of periods are not allowed.\"\n ~pp:(fun ppf () -> Format.fprintf ppf \"Invalid arg\")\n empty\n (function Invalid_arg -> Some () | _ -> None)\n (fun () -> Invalid_arg) ;\n let title = \"Period overflow\" in\n register_error_kind\n `Permanent\n ~id:\"period_overflow\"\n ~title\n ~description:\"Last operation generated an integer overflow.\"\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" title)\n empty\n (function Period_overflow -> Some () | _ -> None)\n (fun () -> Period_overflow)\n\nmodule type INTERNAL = sig\n type t = private int64\n\n val create : int64 -> t option\n\n val zero : t\n\n val one : t\n\n val mult_ : t -> t -> t option\n\n val add_ : t -> t -> t option\n\n val encoding : t Data_encoding.t\n\n val rpc_arg : t RPC_arg.arg\n\n val pp : Format.formatter -> t -> unit\n\n include Compare.S with type t := t\nend\n\n(* Internal module implementing natural numbers using int64. These are different\n from usual (wrapping up) unsigned integers in that if one overflows the\n representation bounds for int64 through [add] or [mul], a [None] value is\n returned *)\nmodule Internal : INTERNAL = struct\n type t = Int64.t\n\n let encoding =\n Data_encoding.(\n with_decoding_guard\n (fun t ->\n if Compare.Int64.(t >= 0L) then Ok ()\n else Error \"Positive int64 required\")\n int64)\n\n let rpc_arg = RPC_arg.uint63\n\n let pp ppf v = Format.fprintf ppf \"%Ld\" v\n\n include (Compare.Int64 : Compare.S with type t := t)\n\n let zero = 0L\n\n let one = 1L\n\n let create t = if t >= zero then Some t else None\n\n (* The create function is not used in the [mul_] and [add_] below to not add\n extra Some | None pattern matching to handle since the overflow checks are\n generic and apply as well to negative as positive integers .\n\n To handle overflows, both [add_] and [mult_] return option types. [None] is\n returned on detected overflow, [Some value] when everything went well. *)\n let mult_ a b =\n if a <> zero then\n let res = Int64.mul a b in\n if Int64.div res a <> b then None else Some res\n else Some zero\n\n let add_ a b =\n let res = Int64.add a b in\n if res < a || res < b then None else Some res\nend\n\ninclude Internal\n\ntype period = Internal.t\n\nlet to_seconds (t : Internal.t) = (t :> int64)\n\nlet of_seconds secs =\n match Internal.create secs with\n | Some v -> ok v\n | None -> error (Malformed_period secs)\n\nlet of_seconds_exn t =\n match Internal.create t with\n | Some t -> t\n | None -> invalid_arg \"Period.of_seconds_exn\"\n\nlet mult i p =\n match Internal.create (Int64.of_int32 i) with\n | None -> error Invalid_arg\n | Some iper -> (\n match Internal.mult_ iper p with\n | None -> error Period_overflow\n | Some res -> ok res)\n\nlet add p1 p2 =\n match Internal.add_ p1 p2 with\n | None -> error Period_overflow\n | Some res -> ok res\n\nlet ( +? ) = add\n\nlet one_second = Internal.one\n\nlet one_minute = of_seconds_exn 60L\n\nlet one_hour = of_seconds_exn 3600L\n" ;
} ;
{ name = "Time_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ninclude module type of struct\n include Time\nend\n\n(** Internal timestamp representation. *)\ntype time = t\n\n(** Pretty-prints the time stamp using RFC3339 format. *)\nval pp : Format.formatter -> t -> unit\n\n(** Parses RFC3339 representation and returns a timestamp. *)\nval of_seconds_string : string -> time option\n\n(** Returns the timestamp encoded in RFC3339 format. *)\nval to_seconds_string : time -> string\n\n(** Adds a time span to a timestamp.\n This function fails on integer overflow *)\nval ( +? ) : time -> Period_repr.t -> time tzresult\n\n(** Returns the difference between two timestamps as a time span.\n This function fails when the difference is negative *)\nval ( -? ) : time -> time -> Period_repr.t tzresult\n\n(** [t - p] Returns a timestamps [p] seconds before [t].\n\n TODO: https://gitlab.com/tezos/tezos/-/issues/2054\n This function should be made available in the environment.\n *)\nval ( - ) : time -> Period_repr.t -> time\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\ninclude Time\n\ntype time = Time.t\n\ntype error += Timestamp_add (* `Permanent *)\n\ntype error += Timestamp_sub (* `Permanent *)\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"timestamp_add\"\n ~title:\"Timestamp add\"\n ~description:\"Overflow when adding timestamps.\"\n ~pp:(fun ppf () -> Format.fprintf ppf \"Overflow when adding timestamps.\")\n Data_encoding.empty\n (function Timestamp_add -> Some () | _ -> None)\n (fun () -> Timestamp_add) ;\n register_error_kind\n `Permanent\n ~id:\"timestamp_sub\"\n ~title:\"Timestamp sub\"\n ~description:\"Subtracting timestamps resulted in negative period.\"\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"Subtracting timestamps resulted in negative period.\")\n Data_encoding.empty\n (function Timestamp_sub -> Some () | _ -> None)\n (fun () -> Timestamp_sub)\n\nlet of_seconds_string s = Option.map Time.of_seconds (Int64.of_string_opt s)\n\nlet to_seconds_string s = Int64.to_string (to_seconds s)\n\nlet pp = pp_hum\n\nlet ( +? ) x y =\n let span = Period_repr.to_seconds y in\n let t64 = Time.add x span in\n (* As long as span and time representations are int64, we cannont overflow if\n x is negative. *)\n if x < Time.of_seconds 0L then ok t64\n else if t64 < Time.of_seconds 0L then error Timestamp_add\n else ok t64\n\nlet ( -? ) x y =\n record_trace Timestamp_sub (Period_repr.of_seconds (Time.diff x y))\n\nlet ( - ) x y =\n Time.of_seconds Int64.(sub (Time.to_seconds x) (Period_repr.to_seconds y))\n" ;
} ;
{ name = "Ratio_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t = {numerator : int; denominator : int}\n\nval encoding : t Data_encoding.t\n\nval pp : Format.formatter -> t -> unit\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t = {numerator : int; denominator : int}\n\nlet encoding =\n let open Data_encoding in\n conv_with_guard\n (fun r -> (r.numerator, r.denominator))\n (fun (numerator, denominator) ->\n if Compare.Int.(denominator > 0) then ok {numerator; denominator}\n else Error \"The denominator must be greater than 0.\")\n (obj2 (req \"numerator\" uint16) (req \"denominator\" uint16))\n\nlet pp fmt {numerator; denominator} =\n Format.fprintf fmt \"%d/%d\" numerator denominator\n" ;
} ;
{ name = "Round_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** A round represents an iteration of the single-shot consensus algorithm.\n\n Rounds can be seen as an infinite, 0-indexed, list of durations. The\n durations are generated by an arithmetic progression depending on\n {!val:Constants_repr.minimal_block_delay} (its initial value, a.k.a the one for\n round 0) and {!val:Constants_repr.delay_increment_per_round} (its common\n difference) .\n\n Round identifiers are non-negative 32 bit integers. This interface ensures\n that no negative round can be created. *)\n\ntype round\n\ntype t = round\n\n(** Round zero *)\nval zero : t\n\n(** Successor of the given round.\n\n @raise Invalid_arg if applied to the upper bound of the round integer\n representation. *)\nval succ : t -> t\n\n(** Predecessor of the given round.\n Returns an error if applied to [zero], as negative round are\n prohibited. *)\nval pred : t -> t tzresult\n\n(** Building a round from an int32.\n Returns an error if applied to a negative number. *)\nval of_int32 : int32 -> t tzresult\n\nval to_int32 : t -> int32\n\n(** Building a round from an int.\n Returns an error if applied to a negative number or a number\n greater than Int32.max_int. *)\nval of_int : int -> t tzresult\n\n(** Building an int from a round.\n Returns an error if the value does not fit in max_int. (current\n 32bit encodings always fit in int on 64bit architecture though). *)\nval to_int : t -> int tzresult\n\n(** Returns the slot corresponding to the given round [r], that is [r\n mod committee_size]. *)\nval to_slot : t -> committee_size:int -> Slot_repr.t tzresult\n\n(** Round encoding.\n Be aware that decoding a negative 32 bit integer would lead to an\n exception. *)\nval encoding : t Data_encoding.t\n\nval pp : Format.formatter -> t -> unit\n\ninclude Compare.S with type t := t\n\nmodule Map : Map.S with type key = t\n\n(** {2 Round duration representation} *)\n\nmodule Durations : sig\n (** [round_durations] represents the duration of rounds in seconds *)\n type t\n\n val pp : Format.formatter -> t -> unit\n\n (** {3 Creation functions} *)\n\n (** [create ~first_round_duration ~delay_increment_per_round] creates a valid\n duration value\n\n @param first_round_duration duration of round 0\n @param delay_increment_per_round amount of time added in from one round\n duration to the duration of its next round\n @raise Invalid_argument if\n - first_round_duration <= 1; or\n - delay_increment_per_round is <= 0\n *)\n val create :\n first_round_duration:Period_repr.t ->\n delay_increment_per_round:Period_repr.t ->\n t tzresult\n\n (** [create_opt ~first_round_duration ~delay_increment_per_round] returns a valid duration value\n [Some d] when [create ~first_round_duration ~delay_increment_per_round]\n does not fail. It returns [None] otherwise. *)\n val create_opt :\n first_round_duration:Period_repr.t ->\n delay_increment_per_round:Period_repr.t ->\n t option\n\n (** {b Warning} May trigger an exception when the expected invariant\n does not hold. *)\n val encoding : t Data_encoding.encoding\n\n (** {3 Accessors}*)\n\n (** [round_duration round_durations ~round] returns the duration of round\n [~round]. This duration follows the arithmetic progression\n\n duration(round_n) = [first_round_duration] + round_n * [delay_increment_per_round]\n\n *)\n val round_duration : t -> round -> Period_repr.t\nend\n\n(** [level_offset_of_round round_durations ~round:r] represents the offset of the\n starting time of round [r] with respect to the start of the level.\n round = 0 1 2 3 r\n\n |-----|-----|-----|-----|-----|--- ... ... --|------|-------\n |\n <------------------------------------------->\n level_offset\n*)\nval level_offset_of_round : Durations.t -> round:t -> Period_repr.t tzresult\n\n(** [timestamp_of_round round_durations ~predecessor_timestamp:pred_ts\n ~predecessor_round:pred_round ~round] returns the\n starting time of round [round] given that the timestamp and the round of\n the block at the previous level is [pred_ts] and [pred_round],\n respectively.\n\n pred_round = 0 pred_round\n\n |-----|.. ... --|--------|-- ... --|-------\n | |\n | |\n pred_ts |\n |\n start_of_cur_level\n |\n |\n |-----|------|-- ... --|-------|-\n cur_round = 0 1 | round\n |\n res_ts\n\n Precisely, the resulting timestamp is:\n [pred_ts + round_duration(pred_round) + level_offset_of_round(round)].\n*)\nval timestamp_of_round :\n Durations.t ->\n predecessor_timestamp:Time_repr.t ->\n predecessor_round:t ->\n round:t ->\n Time_repr.t tzresult\n\n(** [timestamp_of_another_round_same_level\n round_durations\n ~current_timestamp\n ~current_round\n ~considered_round]\n returns the starting time of round [considered_round].\n\n start of current\n level current ts result\n | | |\n | | |\n |-----|----...--|-- ... ------|-\n | | | |\n cur_round = 0 1 current considered\n round round\n\n It also works when [considered_round] is lower than [current_round].\n\n Precisely, the resulting timestamp is:\n [current_timestamp - level_offset_of_round(current_round)\n + level_offset_of_round(considered_round)].\n*)\nval timestamp_of_another_round_same_level :\n Durations.t ->\n current_timestamp:Time_repr.t ->\n current_round:t ->\n considered_round:t ->\n Time_repr.t tzresult\n\n(** [round_of_timestamp round_durations ~predecessor_timestamp ~predecessor_round\n ~timestamp:ts] returns the round to which the timestamp [ts] belongs to,\n given that the timestamp and the round of the block at the previous level is\n [pred_ts] and [pred_round], respectively.\n\n Precisely, the resulting round is:\n [round_and_offset round_durations ~level_offset:diff] where\n [diff = ts - (predecessor_timestamp + round_duration(predecessor_round)].\n\n Returns an error when the timestamp is before the level start. Also\n returns an error when the timestamp is so high that it would lead\n to an integer overflow when computing the round. *)\nval round_of_timestamp :\n Durations.t ->\n predecessor_timestamp:Time_repr.t ->\n predecessor_round:t ->\n timestamp:Time_repr.t ->\n t tzresult\n\nmodule Internals_for_test : sig\n type round_and_offset_raw = {round : round; offset : Period_repr.t}\n\n (** [round_and_offset round_durations ~level_offset], where [level_offset]\n represents a time offset with respect to the start of the first round,\n returns a tuple [(r, round_offset)] where the round [r] is such that\n [level_offset_of_round(r) <= level_offset < level_offset_of_round(r+1)] and\n [round_offset := level_offset - level_offset_of_round(r)].\n\n round = 0 1 2 3 r\n\n |-----|-----|-----|-----|-----|--- ... ... --|--------|-- ... --|-------\n |\n round_delay(r)\n |\n |\n <----->\n round_offset\n <--------------------------------------------------->\n level_offset\n*)\n val round_and_offset :\n Durations.t -> level_offset:Period_repr.t -> round_and_offset_raw tzresult\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype round = int32\n\ntype t = round\n\nmodule Map = Map.Make (Int32)\n\ninclude (Compare.Int32 : Compare.S with type t := t)\n\nlet zero = 0l\n\nlet succ n =\n if Compare.Int32.equal n Int32.max_int then\n invalid_arg \"round_repr.succ: cannot apply succ to maximum round value\"\n else Int32.succ n\n\nlet pp fmt i = Format.fprintf fmt \"%ld\" i\n\ntype error += Negative_round of int\n\ntype error += Round_overflow of int\n\nlet () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"negative_round\"\n ~title:\"Negative round\"\n ~description:\"Round cannot be built out of negative integers.\"\n ~pp:(fun ppf i ->\n Format.fprintf\n ppf\n \"Negative round cannot be built out of negative integers (%Ld)\"\n i)\n (obj1 (req \"Negative_round\" int64))\n (function Negative_round i -> Some (Int64.of_int i) | _ -> None)\n (fun i -> Negative_round (Int64.to_int i)) ;\n register_error_kind\n `Permanent\n ~id:\"round_overflow\"\n ~title:\"Round overflow\"\n ~description:\n \"Round cannot be built out of integer greater than maximum int32 value.\"\n ~pp:(fun ppf i ->\n Format.fprintf\n ppf\n \"Round cannot be built out of integer greater than maximum int32 value \\\n (%Ld)\"\n i)\n (obj1 (req \"Round_overflow\" int64))\n (function Round_overflow i -> Some (Int64.of_int i) | _ -> None)\n (fun i -> Round_overflow (Int64.to_int i))\n\nlet of_int32 i =\n if i >= 0l then Ok i else error (Negative_round (Int32.to_int i))\n [@@inline]\n\nlet pred r =\n let p = Int32.pred r in\n of_int32 p\n\nlet of_int i =\n if Compare.Int.(i < 0) then error (Negative_round i)\n else\n (* i is positive *)\n let i32 = Int32.of_int i in\n if Compare.Int.(Int32.to_int i32 = i) then Ok i32\n else error (Round_overflow i)\n\nlet to_int i32 =\n let i = Int32.to_int i32 in\n if Int32.(equal (of_int i) i32) then ok i else error (Round_overflow i)\n\nlet to_int32 t = t [@@inline]\n\nlet to_slot round ~committee_size =\n to_int round >>? fun r ->\n let slot = r mod committee_size in\n Slot_repr.of_int slot\n\nlet encoding =\n Data_encoding.conv_with_guard\n (fun i -> i)\n (fun i ->\n match of_int32 i with\n | Ok _ as res -> res\n | Error _ -> Error \"Round_repr.encoding: negative round\")\n Data_encoding.int32\n\nmodule Durations = struct\n type t = {\n first_round_duration : Period_repr.t;\n delay_increment_per_round : Period_repr.t;\n }\n\n type error +=\n | Non_increasing_rounds of {increment : Period_repr.t}\n | Round_durations_must_be_at_least_one_second of {round : Period_repr.t}\n\n let () =\n register_error_kind\n `Permanent\n ~id:\"durations.non_increasing_rounds\"\n ~title:\"Non increasing round\"\n ~description:\"The provided rounds are not increasing.\"\n ~pp:(fun ppf increment ->\n Format.fprintf\n ppf\n \"The provided rounds are not increasing (increment: %a)\"\n Period_repr.pp\n increment)\n Data_encoding.(obj1 (req \"increment\" Period_repr.encoding))\n (function\n | Non_increasing_rounds {increment} -> Some increment | _ -> None)\n (fun increment -> Non_increasing_rounds {increment})\n\n let pp fmt t =\n Format.fprintf\n fmt\n \"%a,@ +%a\"\n Period_repr.pp\n t.first_round_duration\n Period_repr.pp\n t.delay_increment_per_round\n\n let create ~first_round_duration ~delay_increment_per_round =\n error_when\n Compare.Int64.(Period_repr.to_seconds first_round_duration < 1L)\n (Round_durations_must_be_at_least_one_second\n {round = first_round_duration})\n >>? fun () ->\n error_when\n Compare.Int64.(Period_repr.to_seconds delay_increment_per_round < 1L)\n (Non_increasing_rounds {increment = delay_increment_per_round})\n >>? fun () -> ok {first_round_duration; delay_increment_per_round}\n\n let create_opt ~first_round_duration ~delay_increment_per_round =\n match create ~first_round_duration ~delay_increment_per_round with\n | Ok v -> Some v\n | Error _ -> None\n\n let encoding =\n let open Data_encoding in\n conv_with_guard\n (fun {first_round_duration; delay_increment_per_round} ->\n (first_round_duration, delay_increment_per_round))\n (fun (first_round_duration, delay_increment_per_round) ->\n match create_opt ~first_round_duration ~delay_increment_per_round with\n | None ->\n Error\n \"Either round durations are non-increasing or minimal block \\\n delay < 1\"\n | Some rounds -> Ok rounds)\n (obj2\n (req \"first_round_duration\" Period_repr.encoding)\n (req \"delay_increment_per_round\" Period_repr.encoding))\n\n let round_duration {first_round_duration; delay_increment_per_round} round =\n if Compare.Int32.(round < 0l) then\n invalid_arg \"round must be a non-negative integer\"\n else\n let first_round_duration_s = Period_repr.to_seconds first_round_duration\n and delay_increment_per_round_s =\n Period_repr.to_seconds delay_increment_per_round\n in\n Period_repr.of_seconds_exn\n Int64.(\n add\n first_round_duration_s\n (mul (of_int32 round) delay_increment_per_round_s))\nend\n\ntype error += Round_too_high of int32\n\nlet () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"round_too_high\"\n ~title:\"round too high\"\n ~description:\"block round too high.\"\n ~pp:(fun ppf round ->\n Format.fprintf ppf \"Block round is too high: %ld\" round)\n (obj1 (req \"level_offset_too_high\" int32))\n (function Round_too_high round -> Some round | _ -> None)\n (fun round -> Round_too_high round)\n\n(* The duration of round n follows the arithmetic sequence:\n\n round_duration(0) = first_round_duration\n round_duration(r+1) = round_duration(r) + delay_increment_per_round\n\n Hence, this sequence can be explicited into:\n\n round_duration(r) = first_round_duration + r * delay_increment_per_round\n\n The level offset of round r is the sum of the durations of the rounds up\n until round r - 1. In other words, when r > 0\n\n raw_level_offset_of_round(0) = 0\n raw_level_offset_of_round(r+1) =\n raw_level_offset_of_round(r) + round_duration(r)\n\n Hence\n\n raw_level_offset_of_round(r) = \206\163_{k=0}^{r-1} (round_duration(k))\n\n After unfolding the series, the same function can be finally explicited into\n\n raw_level_offset_of_round(0) = 0\n raw_level_offset_of_round(r) = r * first_round_duration\n + 1/2 * r * (r - 1) * delay_increment_per_round\n*)\nlet raw_level_offset_of_round round_durations ~round =\n if Compare.Int32.(round = zero) then ok Int64.zero\n else\n let sum_durations =\n let Durations.{first_round_duration; delay_increment_per_round} =\n round_durations\n in\n let roundz = Int64.of_int32 round in\n let m = Z.of_int64 Int64.(div (mul roundz (pred roundz)) (of_int 2)) in\n Z.(\n add\n (mul\n m\n (Z.of_int64 @@ Period_repr.to_seconds delay_increment_per_round))\n (mul\n (Z.of_int32 round)\n (Z.of_int64 @@ Period_repr.to_seconds first_round_duration)))\n in\n if Compare.Z.(sum_durations > Z.of_int64 Int64.max_int) then\n error (Round_too_high round)\n else ok (Z.to_int64 sum_durations)\n\ntype error += Level_offset_too_high of Period_repr.t\n\nlet () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"level_offset_too_high\"\n ~title:\"level offset too high\"\n ~description:\"The block's level offset is too high.\"\n ~pp:(fun ppf offset ->\n Format.fprintf\n ppf\n \"The block's level offset is too high: %a\"\n Period_repr.pp\n offset)\n (obj1 (req \"level_offset_too_high\" Period_repr.encoding))\n (function Level_offset_too_high offset -> Some offset | _ -> None)\n (fun offset -> Level_offset_too_high offset)\n\ntype round_and_offset = {round : int32; offset : Period_repr.t}\n\n(** Complexity: O(log level_offset). *)\nlet round_and_offset round_durations ~level_offset =\n let level_offset_in_seconds = Period_repr.to_seconds level_offset in\n (* We set the bound as 2^53 to prevent overflows when computing the\n variable [discr] for reasonable values of [first_round_duration] and\n [delay_increment_per_round]. This bound is derived by a rough approximation\n from the inequation [discr] < Int64.max_int. *)\n let overflow_bound = Int64.shift_right Int64.max_int 10 in\n if Compare.Int64.(overflow_bound < level_offset_in_seconds) then\n error (Level_offset_too_high level_offset)\n else\n let Durations.{first_round_duration; delay_increment_per_round} =\n round_durations\n in\n let first_round_duration = Period_repr.to_seconds first_round_duration in\n let delay_increment_per_round =\n Period_repr.to_seconds delay_increment_per_round\n in\n (* If [level_offset] is lower than the first round duration, then\n the solution straightforward. *)\n if Compare.Int64.(level_offset_in_seconds < first_round_duration) then\n ok {round = 0l; offset = level_offset}\n else\n let round =\n if Compare.Int64.(delay_increment_per_round = Int64.zero) then\n (* Case when delay_increment_per_round is zero and a simple\n linear solution exists. *)\n Int64.div level_offset_in_seconds first_round_duration\n else\n (* Case when the increment is non-negative and we look for the\n quadratic solution. *)\n let pow_2 n = Int64.mul n n in\n let double n = Int64.shift_left n 1 in\n let times_8 n = Int64.shift_left n 3 in\n let half n = Int64.shift_right n 1 in\n (* The integer square root is implemented using the Newton-Raphson\n method. For any integer N, the convergence within the\n neighborhood of \226\136\154N is ensured within log2 (N) steps. *)\n let sqrt (n : int64) =\n let x0 = ref (half n) in\n if Compare.Int64.(!x0 > 1L) then (\n let x1 = ref (half (Int64.add !x0 (Int64.div n !x0))) in\n while Compare.Int64.(!x1 < !x0) do\n x0 := !x1 ;\n x1 := half (Int64.add !x0 (Int64.div n !x0))\n done ;\n !x0)\n else n\n in\n (* The idea is to solve the following equation in [round] and\n use its integer value:\n\n \206\163_{k=0}^{round-1} round_duration(k) = level_offset\n\n After unfolding the sum and expanding terms, we obtain a\n quadratic equation:\n\n delay_increment_per_round \195\151 round\194\178\n + (2 first_round_duration - delay_increment_per_round) \195\151 round\n - 2 level_offset\n = 0\n\n From there, we compute the discriminant and the solution of\n the equation.\n\n Refer to https://gitlab.com/tezos/tezos/-/merge_requests/4009\n for more explanations.\n *)\n let discr =\n Int64.add\n (pow_2\n (Int64.sub\n (double first_round_duration)\n delay_increment_per_round))\n (times_8\n (Int64.mul delay_increment_per_round level_offset_in_seconds))\n in\n Int64.div\n (Int64.add\n (Int64.sub\n delay_increment_per_round\n (double first_round_duration))\n (sqrt discr))\n (double delay_increment_per_round)\n in\n raw_level_offset_of_round round_durations ~round:(Int64.to_int32 round)\n >>? fun current_level_offset ->\n ok\n {\n round = Int64.to_int32 round;\n offset =\n Period_repr.of_seconds_exn\n (Int64.sub\n (Period_repr.to_seconds level_offset)\n current_level_offset);\n }\n\n(** Complexity: O(|round_durations|). *)\nlet timestamp_of_round round_durations ~predecessor_timestamp ~predecessor_round\n ~round =\n let pred_round_duration =\n Durations.round_duration round_durations predecessor_round\n in\n (* First, the function computes when the current level l is supposed\n to start. This is given by adding to the timestamp of the round\n of predecessor level l-1 [predecessor_timestamp], the duration of\n its last round [predecessor_round]. *)\n Time_repr.(predecessor_timestamp +? pred_round_duration)\n >>? fun start_of_current_level ->\n (* Finally, we sum the durations of the rounds at the current level l until\n reaching current [round]. *)\n raw_level_offset_of_round round_durations ~round >>? fun level_offset ->\n let level_offset = Period_repr.of_seconds_exn level_offset in\n Time_repr.(start_of_current_level +? level_offset)\n\n(** Unlike [timestamp_of_round], this function gets the starting time\n of a given round, given the timestamp and the round of a proposal\n at the same level.\n\n We compute the starting time of [considered_round] from a given\n [round_durations] description, some [current_round], and its\n starting time [current_timestamp].\n\n Complexity: O(|round_durations|). *)\nlet timestamp_of_another_round_same_level round_durations ~current_timestamp\n ~current_round ~considered_round =\n raw_level_offset_of_round round_durations ~round:considered_round\n >>? fun target_offset ->\n raw_level_offset_of_round round_durations ~round:current_round\n >>? fun current_offset ->\n ok\n @@ Time_repr.of_seconds\n Int64.(\n add\n (sub (Time_repr.to_seconds current_timestamp) current_offset)\n target_offset)\n\ntype error +=\n | Round_of_past_timestamp of {\n provided_timestamp : Time.t;\n predecessor_timestamp : Time.t;\n predecessor_round : t;\n }\n\nlet () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"round_of_past_timestamp\"\n ~title:\"Round_of_timestamp for past timestamp\"\n ~description:\"Provided timestamp is before the expected level start.\"\n ~pp:(fun ppf (provided_ts, predecessor_ts, round) ->\n Format.fprintf\n ppf\n \"Provided timestamp (%a) is before the expected level start (computed \\\n based on predecessor_ts %a at round %a).\"\n Time.pp_hum\n provided_ts\n Time.pp_hum\n predecessor_ts\n pp\n round)\n (obj3\n (req \"provided_timestamp\" Time.encoding)\n (req \"predecessor_timestamp\" Time.encoding)\n (req \"predecessor_round\" encoding))\n (function\n | Round_of_past_timestamp\n {provided_timestamp; predecessor_timestamp; predecessor_round} ->\n Some (provided_timestamp, predecessor_timestamp, predecessor_round)\n | _ -> None)\n (fun (provided_timestamp, predecessor_timestamp, predecessor_round) ->\n Round_of_past_timestamp\n {provided_timestamp; predecessor_timestamp; predecessor_round})\n\nlet round_of_timestamp round_durations ~predecessor_timestamp ~predecessor_round\n ~timestamp =\n let round_duration =\n Durations.round_duration round_durations predecessor_round\n in\n Time_repr.(predecessor_timestamp +? round_duration)\n >>? fun start_of_current_level ->\n Period_repr.of_seconds (Time_repr.diff timestamp start_of_current_level)\n |> Error_monad.record_trace\n (Round_of_past_timestamp\n {\n predecessor_timestamp;\n provided_timestamp = timestamp;\n predecessor_round;\n })\n >>? fun diff ->\n round_and_offset round_durations ~level_offset:diff\n >>? fun round_and_offset -> ok round_and_offset.round\n\nlet level_offset_of_round round_durations ~round =\n raw_level_offset_of_round round_durations ~round >>? fun offset ->\n ok (Period_repr.of_seconds_exn offset)\n\nmodule Internals_for_test = struct\n type round_and_offset_raw = {round : round; offset : Period_repr.t}\n\n let round_and_offset round_durations ~level_offset =\n round_and_offset round_durations ~level_offset >|? fun v ->\n {round = v.round; offset = v.offset}\nend\n" ;
} ;
{ name = "Block_payload_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Value on which validators try to reach a consensus.\n\n Consensus at a given level is reached on a sequence of operations. However,\n to differentiate between two blocks having the same sequence of operations,\n assuming that could ever happen (for instance, two empty blocks), we also\n include the hash of the block that precedes the block where these operations\n should be included. *)\n\n(** Create a payload hash from the predecessor block hash, the first\n round at which the payload was proposed, and the hashes of\n non-consensus operations. *)\nval hash :\n predecessor_hash:Block_hash.t ->\n payload_round:Round_repr.t ->\n Operation_list_hash.elt list ->\n Block_payload_hash.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Value on which validators try to reach a consensus.\n\n Consensus at a given level is reached on a sequence of operations. However,\n to differentiate between two blocks having the same sequence of operations,\n assuming that could ever happen (for instance, two empty blocks), we also\n include the hash of the block that precedes the block where these operations\n should be included. *)\n\nlet hash ~predecessor_hash ~payload_round operations =\n let operations_hash = Operation_list_hash.compute operations in\n let open Data_encoding in\n let predecessor = Binary.to_bytes_exn Block_hash.encoding predecessor_hash in\n let round = Binary.to_bytes_exn Round_repr.encoding payload_round in\n let operations_hash =\n Binary.to_bytes_exn Operation_list_hash.encoding operations_hash\n in\n Block_payload_hash.hash_bytes [predecessor; round; operations_hash]\n" ;
} ;
{ name = "Fixed_point_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2020 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module defines a standard signature for modules providing fixed-point\n arithmetic. *)\n\ntype fp_tag (* Tag for fixed point computations *)\n\ntype integral_tag (* Tag for integral computations *)\n\n(** A signature for modules implementing a fixed-point arithmetic.\n\n Fixed-point types come in two flavours:\n - integral (marked with [integral_tag]), behaving like integers;\n - fp (marked with [fp_tag]), allowing for fractions.\n\n Such numbers represent standard arithmetic, rounding (converting fp\n flavour to integral one) and comparisons (which can work across flavours). *)\nmodule type Safe = sig\n type 'a t\n\n type fp = fp_tag t\n\n type integral = integral_tag t\n\n val integral_exn : Z.t -> integral\n\n val integral_of_int_exn : int -> integral\n\n val integral_to_z : integral -> Z.t\n\n val zero : 'a t\n\n val add : 'a t -> 'a t -> 'a t\n\n val sub : 'a t -> 'a t -> 'a t\n\n val ceil : fp -> integral\n\n val floor : fp -> integral\n\n val fp : 'a t -> fp\n\n val ( = ) : 'a t -> 'b t -> bool\n\n val ( <> ) : 'a t -> 'b t -> bool\n\n val ( < ) : 'a t -> 'b t -> bool\n\n val ( <= ) : 'a t -> 'b t -> bool\n\n val ( >= ) : 'a t -> 'b t -> bool\n\n val ( > ) : 'a t -> 'b t -> bool\n\n val compare : 'a t -> 'b t -> int\n\n val equal : 'a t -> 'b t -> bool\n\n val max : 'a t -> 'a t -> 'a t\n\n val min : 'a t -> 'a t -> 'a t\n\n val pp : Format.formatter -> 'a t -> unit\n\n val pp_integral : Format.formatter -> integral -> unit\n\n val n_fp_encoding : fp Data_encoding.t\n\n val n_integral_encoding : integral Data_encoding.t\n\n val z_fp_encoding : fp Data_encoding.t\n\n val z_integral_encoding : integral Data_encoding.t\nend\n\nmodule type Full = sig\n type 'a t\n\n include Safe with type 'a t := 'a t\n\n val unsafe_fp : Z.t -> fp\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2020 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype fp_tag (* Tag for fixed point computations *)\n\ntype integral_tag (* Tag for integral computations *)\n\nmodule type Safe = sig\n type 'a t\n\n type fp = fp_tag t\n\n type integral = integral_tag t\n\n val integral_exn : Z.t -> integral\n\n val integral_of_int_exn : int -> integral\n\n val integral_to_z : integral -> Z.t\n\n val zero : 'a t\n\n val add : 'a t -> 'a t -> 'a t\n\n val sub : 'a t -> 'a t -> 'a t\n\n val ceil : fp -> integral\n\n val floor : fp -> integral\n\n val fp : 'a t -> fp\n\n val ( = ) : 'a t -> 'b t -> bool\n\n val ( <> ) : 'a t -> 'b t -> bool\n\n val ( < ) : 'a t -> 'b t -> bool\n\n val ( <= ) : 'a t -> 'b t -> bool\n\n val ( >= ) : 'a t -> 'b t -> bool\n\n val ( > ) : 'a t -> 'b t -> bool\n\n val compare : 'a t -> 'b t -> int\n\n val equal : 'a t -> 'b t -> bool\n\n val max : 'a t -> 'a t -> 'a t\n\n val min : 'a t -> 'a t -> 'a t\n\n val pp : Format.formatter -> 'a t -> unit\n\n val pp_integral : Format.formatter -> integral -> unit\n\n val n_fp_encoding : fp Data_encoding.t\n\n val n_integral_encoding : integral Data_encoding.t\n\n val z_fp_encoding : fp Data_encoding.t\n\n val z_integral_encoding : integral Data_encoding.t\nend\n\nmodule type Full = sig\n type 'a t\n\n include Safe with type 'a t := 'a t\n\n val unsafe_fp : Z.t -> fp\nend\n" ;
} ;
{ name = "Saturation_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2020 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module provides saturated arithmetic between 0 and 2^62 - 1.\n\n This means that the arithmetic operations provided by this module\n do not overflow. If an operation would produce an integer [x]\n greater than [2 ^ 62 - 1], it is [saturated] to this\n value. Similarly, if an operation would produce a negative integer,\n it outputs [zero] instead.\n\n This saturation arithmetic is used to monitor gas levels. While the\n gas model can produce values beyond 2^62 - 1, there is no point in\n distinguishing these values from 2^62 - 1 because the amount of gas\n available is significantly lower than this limit.\n\n Notice that most saturation arithmetic operations do not behave\n as their standard counterparts when one of their operands is\n saturated. For instance,\n\n (saturated + saturated) - saturated = 0\n\n For more information about saturation arithmetic, take a look at:\n\n https://en.wikipedia.org/wiki/Saturation_arithmetic\n\n*)\n\n(** An integer of type ['a t] is between [0] and [saturated].\n\n The type parameter ['a] is [mul_safe] if the integer is known\n not to overflow when multiplied with another [mul_safe t].\n\n The type parameter ['a] is [may_saturate] if the integer is\n not known to be sufficiently small to prevent overflow during\n multiplication.\n\n*)\ntype 'a t = private int\n\ntype mul_safe\n\ntype may_saturate\n\nval may_saturate : _ t -> may_saturate t\n\n(** [to_int x] returns the underlying integer representing [x]. *)\nval to_int : 'a t -> int\n\n(** 0 *)\nval zero : _ t\n\n(** 1 *)\nval one : _ t\n\n(** 2^62 - 1 *)\nval saturated : may_saturate t\n\n(** We inherit the order over native integers. *)\nval ( >= ) : _ t -> _ t -> bool\n\nval ( > ) : _ t -> _ t -> bool\n\nval ( <= ) : _ t -> _ t -> bool\n\nval ( < ) : _ t -> _ t -> bool\n\nval ( = ) : _ t -> _ t -> bool\n\nval ( <> ) : _ t -> _ t -> bool\n\nval equal : _ t -> _ t -> bool\n\nval min : 'a t -> 'a t -> 'a t\n\nval max : 'a t -> 'a t -> 'a t\n\nval compare : 'a t -> 'b t -> int\n\n(** [a >! b] is [a > b]. Avoids using [to_int]. *)\nval ( >! ) : _ t -> int -> bool\n\n(** [numbits x] returns the number of bits used in the binary representation\n of [x]. *)\nval numbits : 'a t -> int\n\n(** [shift_right x y] behaves like a logical shift of [x] by [y] bits\n to the right. [y] must be between 0 and 63. *)\nval shift_right : 'a t -> int -> 'a t\n\n(** [shift_left x y] behaves like a logical shift of [x] by [y] bits\n to the left. [y] must be between 0 and 63. In cases where [x lsl y]\n is overflowing, [shift_left x y] is [saturated]. *)\nval shift_left : 'a t -> int -> 'a t\n\n(** [mul x y] behaves like multiplication between native integers as\n long as its result stay below [saturated]. Otherwise, [mul] returns\n [saturated]. *)\nval mul : _ t -> _ t -> may_saturate t\n\n(** [mul_safe x] returns a [mul_safe t] only if [x] does not trigger\n overflows when multiplied with another [mul_safe t]. More precisely,\n [x] is safe for fast multiplications if [x < 2147483648]. *)\nval mul_safe : _ t -> mul_safe t option\n\n(** [mul_fast x y] exploits the fact that [x] and [y] are known not to\n provoke overflows during multiplication to perform a mere\n multiplication. *)\nval mul_fast : mul_safe t -> mul_safe t -> may_saturate t\n\n(** [scale_fast x y] exploits the fact that [x] is known not to\n provoke overflows during multiplication to perform a\n multiplication faster than [mul]. *)\nval scale_fast : mul_safe t -> _ t -> may_saturate t\n\n(** [add x y] behaves like addition between native integers as long as\n its result stay below [saturated]. Otherwise, [add] returns\n [saturated]. *)\nval add : _ t -> _ t -> may_saturate t\n\n(** [succ x] is like [add one x] *)\nval succ : _ t -> may_saturate t\n\n(** [sub x y] behaves like subtraction between native integers as long\n as its result stay positive. Otherwise, [sub] returns [zero].\n This function assumes that [x] is not saturated.\n*)\nval sub : 'a t -> _ t -> 'a t\n\n(** [sub_opt x y] behaves like subtraction between native integers as\n long as its result stay positive. Otherwise, [sub] returns\n [None]. *)\nval sub_opt : 'a t -> _ t -> 'a t option\n\n(** [ediv x y] returns [x / y]. This operation never saturates, hence\n it is exactly the same as its native counterpart. [y] is supposed\n to be strictly greater than 0, otherwise this function raises\n [Division_by_zero]. *)\nval ediv : 'a t -> _ t -> 'a t\n\n(** [erem x y] returns [x mod y]. [y] is supposed to be strictly\n greater than 0, otherwise this function raises\n [Division_by_zero]. *)\nval erem : _ t -> 'b t -> 'b t\n\n(** [sqrt x] returns the square root of x, rounded down. *)\nval sqrt : _ t -> 'a t\n\n(** [of_int_opt x] returns [Some x] if [x >= 0] and [x < saturated],\n and [None] otherwise. *)\nval of_int_opt : int -> may_saturate t option\n\n(** [of_z_opt x] returns [Some x] if [x >= 0] and [x < saturated],\n and [None] otherwise. *)\nval of_z_opt : Z.t -> may_saturate t option\n\n(** When a saturated integer is sufficiently small (i.e. strictly less\n than 2147483648), we can assign it the type [mul_safe S.t] to use\n it within fast multiplications, named [S.scale_fast] and\n [S.mul_fast].\n\n The following function allows such type assignment but may raise an\n exception if the assumption is wrong. Therefore, [mul_safe_exn]\n should only be used to define toplevel values, so that these\n exceptions can only occur during startup.\n *)\nval mul_safe_exn : may_saturate t -> mul_safe t\n\n(** [mul_safe_of_int_exn x] is the composition of [of_int_opt] and\n [mul_safe] in the option monad. This function raises [Invalid_argument]\n if [x] is not safe. This function should be used on integer literals\n that are obviously [mul_safe]. *)\nval mul_safe_of_int_exn : int -> mul_safe t\n\n(** [safe_z z] is [of_z_opt x |> saturate_if_undef]. *)\nval safe_z : Z.t -> may_saturate t\n\n(** [safe_int x] is [of_int_opt x |> saturate_if_undef]. *)\nval safe_int : int -> may_saturate t\n\n(** [to_z z] is [Z.of_int]. *)\nval to_z : _ t -> Z.t\n\n(** Encoding for [t] through the encoding for [z] integers. *)\nval z_encoding : _ t Data_encoding.t\n\n(** Encoding for [t] through the encoding for non-negative integers. *)\nval n_encoding : _ t Data_encoding.t\n\n(** A pretty-printer for native integers. *)\nval pp : Format.formatter -> _ t -> unit\n\n(** Syntax for simple representations. *)\nmodule Syntax : sig\n val log2 : _ t -> may_saturate t\n\n val sqrt : _ t -> may_saturate t\n\n val ( + ) : _ t -> _ t -> may_saturate t\n\n val ( - ) : _ t -> _ t -> may_saturate t\n\n val ( * ) : _ t -> _ t -> may_saturate t\n\n val ( < ) : _ t -> _ t -> bool\n\n val ( = ) : _ t -> _ t -> bool\n\n val ( lsr ) : 'a t -> int -> 'a t\n\n val ( lsl ) : 'a t -> int -> 'a t\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2020 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(* let () = assert (Sys.int_size = 63) *)\n\ntype _ t = int\n\ntype mul_safe\n\ntype may_saturate\n\nlet may_saturate : _ t -> may_saturate t = fun x -> x\n\nlet to_int x = x\n\nlet ( < ) : _ t -> _ t -> bool = Compare.Int.( < )\n\nlet ( <= ) : _ t -> _ t -> bool = Compare.Int.( <= )\n\nlet ( > ) : _ t -> _ t -> bool = Compare.Int.( > )\n\nlet ( >= ) : _ t -> _ t -> bool = Compare.Int.( >= )\n\nlet ( = ) : _ t -> _ t -> bool = Compare.Int.( = )\n\nlet equal = ( = )\n\nlet ( <> ) : _ t -> _ t -> bool = Compare.Int.( <> )\n\nlet max : _ t -> _ t -> _ t = fun x y -> if x >= y then x else y\n\nlet min : _ t -> _ t -> _ t = fun x y -> if x >= y then y else x\n\nlet compare : _ t -> _ t -> _ t = Compare.Int.compare\n\nlet saturated = max_int\n\nlet ( >! ) : _ t -> int -> bool = Compare.Int.( > )\n\nlet of_int_opt t = if t >= 0 && t < saturated then Some t else None\n\nlet of_z_opt z =\n match Z.to_int z with int -> of_int_opt int | exception Z.Overflow -> None\n\nlet to_z x = Z.of_int x\n\nlet saturate_if_undef = function None -> saturated | Some x -> x\n\nlet safe_z z = saturate_if_undef @@ of_z_opt z\n\nlet safe_int x = of_int_opt x |> saturate_if_undef\n\nlet numbits x =\n let x = ref x and n = ref 0 in\n (let y = !x lsr 32 in\n if y <> 0 then (\n n := !n + 32 ;\n x := y)) ;\n (let y = !x lsr 16 in\n if y <> 0 then (\n n := !n + 16 ;\n x := y)) ;\n (let y = !x lsr 8 in\n if y <> 0 then (\n n := !n + 8 ;\n x := y)) ;\n (let y = !x lsr 4 in\n if y <> 0 then (\n n := !n + 4 ;\n x := y)) ;\n (let y = !x lsr 2 in\n if y <> 0 then (\n n := !n + 2 ;\n x := y)) ;\n if !x lsr 1 <> 0 then !n + 2 else !n + !x\n\nlet zero = 0\n\nlet one = 1\n\nlet small_enough z =\n (* The following literal triggers an error if compiled under 32-bit\n architectures, please do not modify it. This is a static way to\n ensure that this file is compiled under a 64-bit architecture. *)\n z land 0x7fffffff80000000 = 0\n\nlet mul_safe x = if small_enough x then Some x else None\n\nlet mul_safe_exn x =\n if small_enough x then x\n else failwith (Format.sprintf \"mul_safe_exn: %d must be below 2147483648\" x)\n\nlet mul_safe_of_int_exn x =\n Option.bind (of_int_opt x) mul_safe |> function\n | None ->\n failwith\n (Format.sprintf \"mul_safe_of_int_exn: %d must be below 2147483648\" x)\n | Some x -> x\n\n(* If [x] is positive, shifting to the right will produce a number\n which is positive and is less than [x]. *)\nlet shift_right x y = (x :> int) lsr y\n\nlet shift_left x y =\n if shift_right saturated y < x then saturated else (x :> int) lsl y\n\nlet mul x y =\n (* assert (x >= 0 && y >= 0); *)\n match x with\n | 0 -> 0\n | x ->\n if small_enough x && small_enough y then x * y\n else if Compare.Int.(y > saturated / x) then saturated\n else x * y\n\nlet mul_fast x y = x * y\n\nlet scale_fast x y =\n if x = 0 then 0\n else if small_enough y then x * y\n else if Compare.Int.(y > saturated / x) then saturated\n else x * y\n\nlet add x y =\n let z = x + y in\n if Compare.Int.(z >= 0) then z else saturated\n\nlet succ x = add one x\n\nlet sub x y = Compare.Int.max (x - y) 0\n\nlet sub_opt x y =\n let s = x - y in\n if Compare.Int.(s >= 0) then Some s else None\n\n(* Notice that Z.erem does not behave as mod on negative numbers.\n Fortunately, the inhabitant of [t] are non-negative. *)\nlet erem x y = x mod y\n\nlet ediv x y = x / y\n\nlet sqrt x =\n of_int_opt x\n |> Option.map (fun x -> Z.of_int x |> Z.sqrt |> Z.to_int)\n |> saturate_if_undef\n\nlet t_to_z_exn z =\n match of_z_opt z with\n | None ->\n (* since the encoding is applied to values of type [t]. *) assert false\n | Some x -> x\n\nlet z_encoding = Data_encoding.(check_size 9 (conv to_z t_to_z_exn z))\n\nlet n_encoding = Data_encoding.(check_size 9 (conv to_z t_to_z_exn n))\n\nlet pp fmt x = Format.pp_print_int fmt x\n\nmodule Syntax = struct\n (* This is a good enough approximation. S.log2 0 = 1 *)\n let log2 x = safe_int (1 + numbits x)\n\n let sqrt = sqrt\n\n let ( + ) = add\n\n let ( - ) = sub\n\n let ( * ) = mul\n\n let ( < ) = ( < )\n\n let ( = ) = ( = )\n\n let ( lsr ) = shift_right\n\n let ( lsl ) = shift_left\nend\n" ;
} ;
{ name = "Gas_limit_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Internal representation of the gas limit available to the node baking a new\n block. It should be proportional to the time and energy required to perform a\n computation.\n\n This protects the bakers from performing exceedingly costly computations\n while baking and also allows them to select cheaper-to-compute operations to\n include in their blocks, as their reward for baking a block is not directly\n related to the resources consumed by the machine performing the operation.\n\n It can be [Unaccounted] (unlimited) or [Limited] to some fixed-point value\n (see [Fixed_point_repr] for the details). The value is represented with 3\n decimal places of precision.\n\n All computations on gas are performed in saturation arithmetic (see\n [Saturation_repr]) bounded between [0] and [2 ^ 62 - 1]*)\n\nmodule Arith :\n Fixed_point_repr.Full\n with type 'a t = private Saturation_repr.may_saturate Saturation_repr.t\n\ntype t = Unaccounted | Limited of {remaining : Arith.fp}\n\nval encoding : t Data_encoding.encoding\n\nval pp : Format.formatter -> t -> unit\n\n(** Represents a gas cost of an operation. The gas model is constructed such\n that the cost of each operation is roughly proportional to the time required\n to perform the operation. If the gas cost of an operation exceeds the\n available limit, such an operation is rejected. This is especially meant to\n protect bakers against DoS attacks. *)\ntype cost = Saturation_repr.may_saturate Saturation_repr.t\n\nval cost_encoding : cost Data_encoding.encoding\n\nval pp_cost : Format.formatter -> cost -> unit\n\n(** Print the gas cost as gas unit *)\nval pp_cost_as_gas : Format.formatter -> cost -> unit\n\n(** Subtracts the cost from the current limit. Returns [None] if the limit\n would fall below [0]. *)\nval raw_consume : Arith.fp -> cost -> Arith.fp option\n\n(** The cost of free operation is [0]. *)\nval free : cost\n\n(** Convert a fixed-point amount of gas to a cost. *)\nval cost_of_gas : 'a Arith.t -> cost\n\n(** Convert an amount of milligas expressed as a value of type [int] to [Arith.fp]. *)\nval fp_of_milligas_int : int -> Arith.fp\n\n(** [atomic_step_cost x] corresponds to [x] milliunit of gas. *)\nval atomic_step_cost : _ Saturation_repr.t -> cost\n\n(** [step_cost x] corresponds to [x] units of gas. *)\nval step_cost : _ Saturation_repr.t -> cost\n\n(** Cost of allocating qwords of storage.\n\n [alloc_cost n] estimates the cost of allocating [n] qwords of storage. *)\nval alloc_cost : _ Saturation_repr.t -> cost\n\n(** Cost of allocating bytes in the storage.\n\n [alloc_bytes_cost b] estimates the cost of allocating [b] bytes of\n storage. *)\nval alloc_bytes_cost : int -> cost\n\n(** Cost of allocating bytes in the storage.\n\n [alloc_mbytes_cost b] estimates the cost of allocating [b] bytes of\n storage and the cost of a header to describe these bytes. *)\nval alloc_mbytes_cost : int -> cost\n\n(** Cost of reading the storage.\n\n [read_bytes_const n] estimates the cost of reading [n] bytes of storage. *)\nval read_bytes_cost : int -> cost\n\n(** Cost of writing to storage.\n\n [write_bytes_const n] estimates the cost of writing [n] bytes to the\n storage. *)\nval write_bytes_cost : int -> cost\n\n(** Multiply a cost by a factor. Both arguments are saturated arithmetic values,\n so no negative numbers are involved. *)\nval ( *@ ) : _ Saturation_repr.t -> cost -> cost\n\n(** Add two costs together. *)\nval ( +@ ) : cost -> cost -> cost\n\n(** Ill-formed [gas_limit]: see {!check_gas_limit}. *)\ntype error += Gas_limit_too_high (* `Permanent *)\n\n(** Check that [gas_limit] is well-formed, i.e. it is at most the\n given [hard_gas_limit_per_operation], and it is nonnegative.\n\n @return [Error Gas_limit_too_high] otherwise. *)\nval check_gas_limit :\n hard_gas_limit_per_operation:Arith.integral ->\n gas_limit:'a Arith.t ->\n unit tzresult\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nlet decimals = 3\n\ntype fp_tag\n\ntype integral_tag\n\nmodule S = Saturation_repr\n\n(* 1 gas unit *)\nlet scaling_factor = 1000\n\nlet mul_scaling_factor = S.mul_safe_of_int_exn scaling_factor\n\nmodule Arith = struct\n type 'a t = S.may_saturate S.t\n\n type fp = fp_tag t\n\n type integral = integral_tag t\n\n let mul_scaling_factor = mul_scaling_factor\n\n let sub = S.sub\n\n let add = S.add\n\n let zero = S.zero\n\n let min = S.min\n\n let max = S.max\n\n let compare = S.compare\n\n let ( < ) = S.( < )\n\n let ( <> ) = S.( <> )\n\n let ( > ) = S.( > )\n\n let ( <= ) = S.( <= )\n\n let ( >= ) = S.( >= )\n\n let ( = ) = S.( = )\n\n let equal = S.equal\n\n let of_int_opt = S.of_int_opt\n\n let fatally_saturated_int i =\n failwith (string_of_int i ^ \" should not be saturated.\")\n\n let fatally_saturated_z z =\n failwith (Z.to_string z ^ \" should not be saturated.\")\n\n let integral_of_int_exn i =\n S.(\n match of_int_opt i with\n | None -> fatally_saturated_int i\n | Some i' ->\n let r = scale_fast mul_scaling_factor i' in\n if r = saturated then fatally_saturated_int i else r)\n\n let integral_exn z =\n match Z.to_int z with\n | i -> integral_of_int_exn i\n | exception Z.Overflow -> fatally_saturated_z z\n\n let integral_to_z (i : integral) : Z.t = S.(to_z (ediv i mul_scaling_factor))\n\n let ceil x =\n let r = S.erem x mul_scaling_factor in\n if r = zero then x else add x (sub mul_scaling_factor r)\n\n let floor x = sub x (S.erem x mul_scaling_factor)\n\n let fp x = x\n\n let pp fmtr fp =\n let q = S.(ediv fp mul_scaling_factor |> to_int) in\n let r = S.(erem fp mul_scaling_factor |> to_int) in\n if Compare.Int.(r = 0) then Format.fprintf fmtr \"%d\" q\n else Format.fprintf fmtr \"%d.%0*d\" q decimals r\n\n let pp_integral = pp\n\n let n_fp_encoding : fp Data_encoding.t = S.n_encoding\n\n let z_fp_encoding : fp Data_encoding.t = S.z_encoding\n\n let n_integral_encoding : integral Data_encoding.t =\n Data_encoding.conv integral_to_z integral_exn Data_encoding.n\n\n let z_integral_encoding : integral Data_encoding.t =\n Data_encoding.conv integral_to_z integral_exn Data_encoding.z\n\n let unsafe_fp x =\n match of_int_opt (Z.to_int x) with\n | Some int -> int\n | None -> fatally_saturated_z x\n\n let sub_opt = S.sub_opt\nend\n\ntype t = Unaccounted | Limited of {remaining : Arith.fp}\n\ntype cost = S.may_saturate S.t\n\nlet encoding =\n let open Data_encoding in\n union\n [\n case\n (Tag 0)\n ~title:\"Limited\"\n Arith.z_fp_encoding\n (function Limited {remaining} -> Some remaining | _ -> None)\n (fun remaining -> Limited {remaining});\n case\n (Tag 1)\n ~title:\"Unaccounted\"\n (constant \"unaccounted\")\n (function Unaccounted -> Some () | _ -> None)\n (fun () -> Unaccounted);\n ]\n\nlet pp ppf = function\n | Unaccounted -> Format.fprintf ppf \"unaccounted\"\n | Limited {remaining} ->\n Format.fprintf ppf \"%a units remaining\" Arith.pp remaining\n\nlet cost_encoding = S.z_encoding\n\nlet pp_cost fmt z = S.pp fmt z\n\nlet pp_cost_as_gas fmt z =\n Format.pp_print_int fmt (S.to_int (Arith.ceil z) / scaling_factor)\n\n(* 2 units of gas *)\nlet allocation_weight =\n S.(mul_fast mul_scaling_factor (S.mul_safe_of_int_exn 2)) |> S.mul_safe_exn\n\nlet step_weight = mul_scaling_factor\n\n(* 100 units of gas *)\nlet read_base_weight =\n S.(mul_fast mul_scaling_factor (S.mul_safe_of_int_exn 100)) |> S.mul_safe_exn\n\n(* 160 units of gas *)\nlet write_base_weight =\n S.(mul_fast mul_scaling_factor (S.mul_safe_of_int_exn 160)) |> S.mul_safe_exn\n\n(* 10 units of gas *)\nlet byte_read_weight =\n S.(mul_fast mul_scaling_factor (S.mul_safe_of_int_exn 10)) |> S.mul_safe_exn\n\n(* 15 units of gas *)\nlet byte_written_weight =\n S.(mul_fast mul_scaling_factor (S.mul_safe_of_int_exn 15)) |> S.mul_safe_exn\n\nlet cost_to_milligas (cost : cost) : Arith.fp = cost\n\nlet raw_consume gas_counter cost =\n let gas = cost_to_milligas cost in\n Arith.sub_opt gas_counter gas\n\nlet alloc_cost n =\n S.scale_fast allocation_weight S.(add n (S.mul_safe_of_int_exn 1))\n\nlet alloc_bytes_cost n = alloc_cost (S.safe_int ((n + 7) / 8))\n\nlet atomic_step_cost : 'a S.t -> cost = S.may_saturate\n\nlet step_cost n = S.scale_fast step_weight n\n\nlet free = S.zero\n\nlet cost_of_gas (gas : 'a Arith.t) = (gas :> cost)\n\nlet fp_of_milligas_int milligas =\n (Saturation_repr.safe_int milligas :> Arith.fp)\n\nlet read_bytes_cost n =\n S.add read_base_weight (S.scale_fast byte_read_weight (S.safe_int n))\n\nlet write_bytes_cost n =\n S.add write_base_weight (S.scale_fast byte_written_weight (S.safe_int n))\n\nlet ( +@ ) x y = S.add x y\n\nlet ( *@ ) x y = S.mul x y\n\nlet alloc_mbytes_cost n =\n alloc_cost (S.mul_safe_of_int_exn 12) +@ alloc_bytes_cost n\n\ntype error += Gas_limit_too_high (* `Permanent *)\n\nlet () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"gas_limit_too_high\"\n ~title:\"Gas limit out of protocol hard bounds\"\n ~description:\"A transaction tried to exceed the hard limit on gas\"\n empty\n (function Gas_limit_too_high -> Some () | _ -> None)\n (fun () -> Gas_limit_too_high)\n\nlet check_gas_limit ~(hard_gas_limit_per_operation : Arith.integral)\n ~(gas_limit : Arith.integral) =\n error_unless\n Arith.(gas_limit <= hard_gas_limit_per_operation && gas_limit >= zero)\n Gas_limit_too_high\n" ;
} ;
{ name = "Constants_parametric_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020-2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2021-2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype dal = {\n feature_enable : bool;\n number_of_slots : int;\n attestation_lag : int;\n availability_threshold : int;\n cryptobox_parameters : Dal.parameters;\n}\n\nval dal_encoding : dal Data_encoding.t\n\ntype tx_rollup = {\n enable : bool;\n origination_size : int;\n (* the maximum amount of bytes messages can allocate in an inbox *)\n hard_size_limit_per_inbox : int;\n (* the maximum amount of bytes one batch can allocate in an inbox *)\n hard_size_limit_per_message : int;\n (* the amount of tez to bond a tx rollup commitment *)\n commitment_bond : Tez_repr.t;\n (* the number of blocks before a tx rollup block is final *)\n finality_period : int;\n (* the maximum number of levels that can be left unfinalized\n before we stop accepting new inboxes for a tx rollup *)\n (* the minimum number of blocks to wait before removing a finalised\n commitment from the context. *)\n withdraw_period : int;\n max_inboxes_count : int;\n (* the maximum number of messages in an inbox. This bounds the\n size of a commitment. *)\n max_messages_per_inbox : int;\n (* the maximum number of finalized commitments, to ensure that\n remove_commitment is ever called *)\n max_commitments_count : int;\n (* The number of blocks used to compute the ema factor determining\n the cost per byte for new messages in the inbox. *)\n cost_per_byte_ema_factor : int;\n (* Tickets are transmitted in batches in the\n [Tx_rollup_dispatch_tickets] operation.\n\n The semantics is that this operation is used to\n concretize the withdraw orders emitted by the layer-2,\n one layer-1 operation per messages of an\n inbox. Therefore, it is of significant importance that\n a valid batch does not produce a list of withdraw\n orders which could not fit in a layer-1 operation.\n\n With these values, at least 2048 bytes remain available\n to store the rest of the operands of\n [Tx_rollup_dispatch_tickets] (in practice, even more,\n because we overapproximate the size of tickets). So we\n are safe. *)\n max_ticket_payload_size : int;\n max_withdrawals_per_batch : int;\n (* The maximum size, in bytes, of a Merkle proof. Operations which would\n require proofs larger than this should be no-ops. *)\n rejection_max_proof_size : int;\n sunset_level : int32;\n}\n\ntype sc_rollup = {\n enable : bool;\n arith_pvm_enable : bool;\n origination_size : int;\n challenge_window_in_blocks : int;\n stake_amount : Tez_repr.t;\n (* The period with which commitments are made. *)\n commitment_period_in_blocks : int;\n (* The maximum depth of a staker's position - chosen alongside\n [commitment_period_in_blocks] to prevent the cost\n of a staker's commitments' storage being greater than their deposit. *)\n max_lookahead_in_blocks : int32;\n (* Maximum number of active outbox levels allowed. An outbox level is active\n if it has an associated record of applied messages. *)\n max_active_outbox_levels : int32;\n max_outbox_messages_per_level : int;\n (* The default number of required sections in a dissection *)\n number_of_sections_in_dissection : int;\n (* The timeout period for a player in a refutation game.\n\n Timeout logic is similar to a chess clock. Each player starts with the same\n timeout = [timeout_period_in_blocks]. Each game move updates the timeout of\n the current player by decreasing it by the amount of time she took to play,\n i.e. number of blocks since the opponent last move. See\n {!Sc_rollup_game_repr.timeout} and\n {!Sc_rollup_refutation_storage.game_move} to see the implementation.\n\n Because of that [timeout_period_in_blocks] must be at least half the upper\n bound number of blocks needed for a game to finish. This bound is\n correlated to the maximum distance allowed between the first and last tick\n of a dissection. For example, when the maximum distance allowed is half the\n total distance [(last_tick - last_tick) / 2] then bound is [Log^2\n (Int64.max_int) + 2 = 65]. See {!Sc_rollup_game_repr.check_dissection} for\n more information on the dissection logic. *)\n timeout_period_in_blocks : int;\n (* The maximum number of cemented commitments stored for a sc rollup. *)\n max_number_of_stored_cemented_commitments : int;\n (* The maximum number of parallel games played by a given staker. *)\n max_number_of_parallel_games : int;\n}\n\ntype zk_rollup = {\n enable : bool;\n origination_size : int;\n (* Minimum number of pending operations that can be processed by a ZKRU\n update, if available.\n If the length of the pending list is less than [min_pending_to_process],\n then an update needs to process all pending operations to be valid.\n That is, every update must process at least\n [min(length pending_list, min_pending_to_process)] pending operations. *)\n min_pending_to_process : int;\n}\n\ntype t = {\n preserved_cycles : int;\n blocks_per_cycle : int32;\n blocks_per_commitment : int32;\n nonce_revelation_threshold : int32;\n blocks_per_stake_snapshot : int32;\n cycles_per_voting_period : int32;\n hard_gas_limit_per_operation : Gas_limit_repr.Arith.integral;\n hard_gas_limit_per_block : Gas_limit_repr.Arith.integral;\n proof_of_work_threshold : int64;\n minimal_stake : Tez_repr.t;\n vdf_difficulty : int64;\n seed_nonce_revelation_tip : Tez_repr.t;\n origination_size : int;\n baking_reward_fixed_portion : Tez_repr.t;\n baking_reward_bonus_per_slot : Tez_repr.t;\n endorsing_reward_per_slot : Tez_repr.t;\n cost_per_byte : Tez_repr.t;\n hard_storage_limit_per_operation : Z.t;\n quorum_min : int32;\n (* in centile of a percentage *)\n quorum_max : int32;\n min_proposal_quorum : int32;\n liquidity_baking_subsidy : Tez_repr.t;\n liquidity_baking_toggle_ema_threshold : int32;\n max_operations_time_to_live : int;\n minimal_block_delay : Period_repr.t;\n delay_increment_per_round : Period_repr.t;\n minimal_participation_ratio : Ratio_repr.t;\n consensus_committee_size : int;\n (* in slots *)\n consensus_threshold : int;\n (* in slots *)\n max_slashing_period : int;\n (* in cycles *)\n frozen_deposits_percentage : int;\n (* that is, (100 * delegated tz / own tz) *)\n double_baking_punishment : Tez_repr.t;\n ratio_of_frozen_deposits_slashed_per_double_endorsement : Ratio_repr.t;\n testnet_dictator : Signature.Public_key_hash.t option;\n initial_seed : State_hash.t option;\n cache_script_size : int;\n (* in bytes *)\n cache_stake_distribution_cycles : int;\n (* in cycles *)\n cache_sampler_state_cycles : int;\n (* in cycles *)\n tx_rollup : tx_rollup;\n dal : dal;\n sc_rollup : sc_rollup;\n zk_rollup : zk_rollup;\n}\n\nval encoding : t Data_encoding.encoding\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020-2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2021-2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype dal = {\n feature_enable : bool;\n number_of_slots : int;\n attestation_lag : int;\n availability_threshold : int;\n cryptobox_parameters : Dal.parameters;\n}\n\nlet dal_encoding =\n let open Data_encoding in\n conv\n (fun {\n feature_enable;\n number_of_slots;\n attestation_lag;\n availability_threshold;\n cryptobox_parameters;\n } ->\n ( ( feature_enable,\n number_of_slots,\n attestation_lag,\n availability_threshold ),\n cryptobox_parameters ))\n (fun ( ( feature_enable,\n number_of_slots,\n attestation_lag,\n availability_threshold ),\n cryptobox_parameters ) ->\n {\n feature_enable;\n number_of_slots;\n attestation_lag;\n availability_threshold;\n cryptobox_parameters;\n })\n (merge_objs\n (obj4\n (req \"feature_enable\" bool)\n (req \"number_of_slots\" int16)\n (req \"attestation_lag\" int16)\n (req \"availability_threshold\" int16))\n Dal.parameters_encoding)\n\n(* The encoded representation of this type is stored in the context as\n bytes. Changing the encoding, or the value of these constants from\n the previous protocol may break the context migration, or (even\n worse) yield an incorrect context after migration.\n\n If you change this encoding compared to `Constants_parametric_previous_repr.t`,\n you should ensure that there is a proper migration of the constants\n during context migration. See: `Raw_context.prepare_first_block` *)\n\ntype tx_rollup = {\n enable : bool;\n origination_size : int;\n hard_size_limit_per_inbox : int;\n hard_size_limit_per_message : int;\n commitment_bond : Tez_repr.t;\n finality_period : int;\n withdraw_period : int;\n max_inboxes_count : int;\n max_messages_per_inbox : int;\n max_commitments_count : int;\n cost_per_byte_ema_factor : int;\n max_ticket_payload_size : int;\n max_withdrawals_per_batch : int;\n rejection_max_proof_size : int;\n sunset_level : int32;\n}\n\ntype sc_rollup = {\n enable : bool;\n arith_pvm_enable : bool;\n origination_size : int;\n challenge_window_in_blocks : int;\n stake_amount : Tez_repr.t;\n commitment_period_in_blocks : int;\n max_lookahead_in_blocks : int32;\n max_active_outbox_levels : int32;\n max_outbox_messages_per_level : int;\n number_of_sections_in_dissection : int;\n timeout_period_in_blocks : int;\n max_number_of_stored_cemented_commitments : int;\n max_number_of_parallel_games : int;\n}\n\ntype zk_rollup = {\n enable : bool;\n origination_size : int;\n min_pending_to_process : int;\n}\n\ntype t = {\n preserved_cycles : int;\n blocks_per_cycle : int32;\n blocks_per_commitment : int32;\n nonce_revelation_threshold : int32;\n blocks_per_stake_snapshot : int32;\n cycles_per_voting_period : int32;\n hard_gas_limit_per_operation : Gas_limit_repr.Arith.integral;\n hard_gas_limit_per_block : Gas_limit_repr.Arith.integral;\n proof_of_work_threshold : int64;\n minimal_stake : Tez_repr.t;\n vdf_difficulty : int64;\n seed_nonce_revelation_tip : Tez_repr.t;\n origination_size : int;\n baking_reward_fixed_portion : Tez_repr.t;\n baking_reward_bonus_per_slot : Tez_repr.t;\n endorsing_reward_per_slot : Tez_repr.t;\n cost_per_byte : Tez_repr.t;\n hard_storage_limit_per_operation : Z.t;\n quorum_min : int32;\n quorum_max : int32;\n min_proposal_quorum : int32;\n liquidity_baking_subsidy : Tez_repr.t;\n liquidity_baking_toggle_ema_threshold : int32;\n max_operations_time_to_live : int;\n minimal_block_delay : Period_repr.t;\n delay_increment_per_round : Period_repr.t;\n minimal_participation_ratio : Ratio_repr.t;\n consensus_committee_size : int;\n consensus_threshold : int;\n max_slashing_period : int;\n frozen_deposits_percentage : int;\n double_baking_punishment : Tez_repr.t;\n ratio_of_frozen_deposits_slashed_per_double_endorsement : Ratio_repr.t;\n testnet_dictator : Signature.Public_key_hash.t option;\n initial_seed : State_hash.t option;\n (* If a new cache is added, please also modify the\n [cache_layout_size] value. *)\n cache_script_size : int;\n cache_stake_distribution_cycles : int;\n cache_sampler_state_cycles : int;\n tx_rollup : tx_rollup;\n dal : dal;\n sc_rollup : sc_rollup;\n zk_rollup : zk_rollup;\n}\n\nlet tx_rollup_encoding =\n let open Data_encoding in\n conv\n (fun (c : tx_rollup) ->\n ( ( c.enable,\n c.origination_size,\n c.hard_size_limit_per_inbox,\n c.hard_size_limit_per_message,\n c.max_withdrawals_per_batch,\n c.commitment_bond,\n c.finality_period,\n c.withdraw_period,\n c.max_inboxes_count,\n c.max_messages_per_inbox ),\n ( c.max_commitments_count,\n c.cost_per_byte_ema_factor,\n c.max_ticket_payload_size,\n c.rejection_max_proof_size,\n c.sunset_level ) ))\n (fun ( ( tx_rollup_enable,\n tx_rollup_origination_size,\n tx_rollup_hard_size_limit_per_inbox,\n tx_rollup_hard_size_limit_per_message,\n tx_rollup_max_withdrawals_per_batch,\n tx_rollup_commitment_bond,\n tx_rollup_finality_period,\n tx_rollup_withdraw_period,\n tx_rollup_max_inboxes_count,\n tx_rollup_max_messages_per_inbox ),\n ( tx_rollup_max_commitments_count,\n tx_rollup_cost_per_byte_ema_factor,\n tx_rollup_max_ticket_payload_size,\n tx_rollup_rejection_max_proof_size,\n tx_rollup_sunset_level ) ) ->\n {\n enable = tx_rollup_enable;\n origination_size = tx_rollup_origination_size;\n hard_size_limit_per_inbox = tx_rollup_hard_size_limit_per_inbox;\n hard_size_limit_per_message = tx_rollup_hard_size_limit_per_message;\n max_withdrawals_per_batch = tx_rollup_max_withdrawals_per_batch;\n commitment_bond = tx_rollup_commitment_bond;\n finality_period = tx_rollup_finality_period;\n withdraw_period = tx_rollup_withdraw_period;\n max_inboxes_count = tx_rollup_max_inboxes_count;\n max_messages_per_inbox = tx_rollup_max_messages_per_inbox;\n max_commitments_count = tx_rollup_max_commitments_count;\n cost_per_byte_ema_factor = tx_rollup_cost_per_byte_ema_factor;\n max_ticket_payload_size = tx_rollup_max_ticket_payload_size;\n rejection_max_proof_size = tx_rollup_rejection_max_proof_size;\n sunset_level = tx_rollup_sunset_level;\n })\n (merge_objs\n (obj10\n (req \"tx_rollup_enable\" bool)\n (req \"tx_rollup_origination_size\" int31)\n (req \"tx_rollup_hard_size_limit_per_inbox\" int31)\n (req \"tx_rollup_hard_size_limit_per_message\" int31)\n (req \"tx_rollup_max_withdrawals_per_batch\" int31)\n (req \"tx_rollup_commitment_bond\" Tez_repr.encoding)\n (req \"tx_rollup_finality_period\" int31)\n (req \"tx_rollup_withdraw_period\" int31)\n (req \"tx_rollup_max_inboxes_count\" int31)\n (req \"tx_rollup_max_messages_per_inbox\" int31))\n (obj5\n (req \"tx_rollup_max_commitments_count\" int31)\n (req \"tx_rollup_cost_per_byte_ema_factor\" int31)\n (req \"tx_rollup_max_ticket_payload_size\" int31)\n (req \"tx_rollup_rejection_max_proof_size\" int31)\n (req \"tx_rollup_sunset_level\" int32)))\n\nlet sc_rollup_encoding =\n let open Data_encoding in\n conv\n (fun (c : sc_rollup) ->\n ( ( c.enable,\n c.arith_pvm_enable,\n c.origination_size,\n c.challenge_window_in_blocks,\n c.stake_amount,\n c.commitment_period_in_blocks,\n c.max_lookahead_in_blocks,\n c.max_active_outbox_levels,\n c.max_outbox_messages_per_level ),\n ( c.number_of_sections_in_dissection,\n c.timeout_period_in_blocks,\n c.max_number_of_stored_cemented_commitments,\n c.max_number_of_parallel_games ) ))\n (fun ( ( sc_rollup_enable,\n sc_rollup_arith_pvm_enable,\n sc_rollup_origination_size,\n sc_rollup_challenge_window_in_blocks,\n sc_rollup_stake_amount,\n sc_rollup_commitment_period_in_blocks,\n sc_rollup_max_lookahead_in_blocks,\n sc_rollup_max_active_outbox_levels,\n sc_rollup_max_outbox_messages_per_level ),\n ( sc_rollup_number_of_sections_in_dissection,\n sc_rollup_timeout_period_in_blocks,\n sc_rollup_max_number_of_cemented_commitments,\n sc_rollup_max_number_of_parallel_games ) ) ->\n {\n enable = sc_rollup_enable;\n arith_pvm_enable = sc_rollup_arith_pvm_enable;\n origination_size = sc_rollup_origination_size;\n challenge_window_in_blocks = sc_rollup_challenge_window_in_blocks;\n stake_amount = sc_rollup_stake_amount;\n commitment_period_in_blocks = sc_rollup_commitment_period_in_blocks;\n max_lookahead_in_blocks = sc_rollup_max_lookahead_in_blocks;\n max_active_outbox_levels = sc_rollup_max_active_outbox_levels;\n max_outbox_messages_per_level = sc_rollup_max_outbox_messages_per_level;\n number_of_sections_in_dissection =\n sc_rollup_number_of_sections_in_dissection;\n timeout_period_in_blocks = sc_rollup_timeout_period_in_blocks;\n max_number_of_stored_cemented_commitments =\n sc_rollup_max_number_of_cemented_commitments;\n max_number_of_parallel_games = sc_rollup_max_number_of_parallel_games;\n })\n (merge_objs\n (obj9\n (req \"smart_rollup_enable\" bool)\n (req \"smart_rollup_arith_pvm_enable\" bool)\n (req \"smart_rollup_origination_size\" int31)\n (req \"smart_rollup_challenge_window_in_blocks\" int31)\n (req \"smart_rollup_stake_amount\" Tez_repr.encoding)\n (req \"smart_rollup_commitment_period_in_blocks\" int31)\n (req \"smart_rollup_max_lookahead_in_blocks\" int32)\n (req \"smart_rollup_max_active_outbox_levels\" int32)\n (req \"smart_rollup_max_outbox_messages_per_level\" int31))\n (obj4\n (req \"smart_rollup_number_of_sections_in_dissection\" uint8)\n (req \"smart_rollup_timeout_period_in_blocks\" int31)\n (req \"smart_rollup_max_number_of_cemented_commitments\" int31)\n (req \"smart_rollup_max_number_of_parallel_games\" int31)))\n\nlet zk_rollup_encoding =\n let open Data_encoding in\n conv\n (fun ({enable; origination_size; min_pending_to_process} : zk_rollup) ->\n (enable, origination_size, min_pending_to_process))\n (fun ( zk_rollup_enable,\n zk_rollup_origination_size,\n zk_rollup_min_pending_to_process ) ->\n {\n enable = zk_rollup_enable;\n origination_size = zk_rollup_origination_size;\n min_pending_to_process = zk_rollup_min_pending_to_process;\n })\n (obj3\n (req \"zk_rollup_enable\" bool)\n (req \"zk_rollup_origination_size\" int31)\n (req \"zk_rollup_min_pending_to_process\" int31))\n\nlet encoding =\n let open Data_encoding in\n conv\n (fun c ->\n ( ( c.preserved_cycles,\n c.blocks_per_cycle,\n c.blocks_per_commitment,\n c.nonce_revelation_threshold,\n c.blocks_per_stake_snapshot,\n c.cycles_per_voting_period,\n c.hard_gas_limit_per_operation,\n c.hard_gas_limit_per_block,\n c.proof_of_work_threshold,\n c.minimal_stake ),\n ( ( c.vdf_difficulty,\n c.seed_nonce_revelation_tip,\n c.origination_size,\n c.baking_reward_fixed_portion,\n c.baking_reward_bonus_per_slot,\n c.endorsing_reward_per_slot,\n c.cost_per_byte,\n c.hard_storage_limit_per_operation,\n c.quorum_min ),\n ( ( c.quorum_max,\n c.min_proposal_quorum,\n c.liquidity_baking_subsidy,\n c.liquidity_baking_toggle_ema_threshold,\n c.max_operations_time_to_live,\n c.minimal_block_delay,\n c.delay_increment_per_round,\n c.consensus_committee_size,\n c.consensus_threshold ),\n ( ( c.minimal_participation_ratio,\n c.max_slashing_period,\n c.frozen_deposits_percentage,\n c.double_baking_punishment,\n c.ratio_of_frozen_deposits_slashed_per_double_endorsement,\n c.testnet_dictator,\n c.initial_seed ),\n ( ( c.cache_script_size,\n c.cache_stake_distribution_cycles,\n c.cache_sampler_state_cycles ),\n (c.tx_rollup, (c.dal, (c.sc_rollup, c.zk_rollup))) ) ) ) ) ))\n (fun ( ( preserved_cycles,\n blocks_per_cycle,\n blocks_per_commitment,\n nonce_revelation_threshold,\n blocks_per_stake_snapshot,\n cycles_per_voting_period,\n hard_gas_limit_per_operation,\n hard_gas_limit_per_block,\n proof_of_work_threshold,\n minimal_stake ),\n ( ( vdf_difficulty,\n seed_nonce_revelation_tip,\n origination_size,\n baking_reward_fixed_portion,\n baking_reward_bonus_per_slot,\n endorsing_reward_per_slot,\n cost_per_byte,\n hard_storage_limit_per_operation,\n quorum_min ),\n ( ( quorum_max,\n min_proposal_quorum,\n liquidity_baking_subsidy,\n liquidity_baking_toggle_ema_threshold,\n max_operations_time_to_live,\n minimal_block_delay,\n delay_increment_per_round,\n consensus_committee_size,\n consensus_threshold ),\n ( ( minimal_participation_ratio,\n max_slashing_period,\n frozen_deposits_percentage,\n double_baking_punishment,\n ratio_of_frozen_deposits_slashed_per_double_endorsement,\n testnet_dictator,\n initial_seed ),\n ( ( cache_script_size,\n cache_stake_distribution_cycles,\n cache_sampler_state_cycles ),\n (tx_rollup, (dal, (sc_rollup, zk_rollup))) ) ) ) ) ) ->\n {\n preserved_cycles;\n blocks_per_cycle;\n blocks_per_commitment;\n nonce_revelation_threshold;\n blocks_per_stake_snapshot;\n cycles_per_voting_period;\n hard_gas_limit_per_operation;\n hard_gas_limit_per_block;\n proof_of_work_threshold;\n minimal_stake;\n vdf_difficulty;\n seed_nonce_revelation_tip;\n origination_size;\n baking_reward_fixed_portion;\n baking_reward_bonus_per_slot;\n endorsing_reward_per_slot;\n cost_per_byte;\n hard_storage_limit_per_operation;\n quorum_min;\n quorum_max;\n min_proposal_quorum;\n liquidity_baking_subsidy;\n liquidity_baking_toggle_ema_threshold;\n max_operations_time_to_live;\n minimal_block_delay;\n delay_increment_per_round;\n minimal_participation_ratio;\n max_slashing_period;\n consensus_committee_size;\n consensus_threshold;\n frozen_deposits_percentage;\n double_baking_punishment;\n ratio_of_frozen_deposits_slashed_per_double_endorsement;\n testnet_dictator;\n initial_seed;\n cache_script_size;\n cache_stake_distribution_cycles;\n cache_sampler_state_cycles;\n tx_rollup;\n dal;\n sc_rollup;\n zk_rollup;\n })\n (merge_objs\n (obj10\n (req \"preserved_cycles\" uint8)\n (req \"blocks_per_cycle\" int32)\n (req \"blocks_per_commitment\" int32)\n (req \"nonce_revelation_threshold\" int32)\n (req \"blocks_per_stake_snapshot\" int32)\n (req \"cycles_per_voting_period\" int32)\n (req\n \"hard_gas_limit_per_operation\"\n Gas_limit_repr.Arith.z_integral_encoding)\n (req\n \"hard_gas_limit_per_block\"\n Gas_limit_repr.Arith.z_integral_encoding)\n (req \"proof_of_work_threshold\" int64)\n (req \"minimal_stake\" Tez_repr.encoding))\n (merge_objs\n (obj9\n (req \"vdf_difficulty\" int64)\n (req \"seed_nonce_revelation_tip\" Tez_repr.encoding)\n (req \"origination_size\" int31)\n (req \"baking_reward_fixed_portion\" Tez_repr.encoding)\n (req \"baking_reward_bonus_per_slot\" Tez_repr.encoding)\n (req \"endorsing_reward_per_slot\" Tez_repr.encoding)\n (req \"cost_per_byte\" Tez_repr.encoding)\n (req \"hard_storage_limit_per_operation\" z)\n (req \"quorum_min\" int32))\n (merge_objs\n (obj9\n (req \"quorum_max\" int32)\n (req \"min_proposal_quorum\" int32)\n (req \"liquidity_baking_subsidy\" Tez_repr.encoding)\n (req \"liquidity_baking_toggle_ema_threshold\" int32)\n (req \"max_operations_time_to_live\" int16)\n (req \"minimal_block_delay\" Period_repr.encoding)\n (req \"delay_increment_per_round\" Period_repr.encoding)\n (req \"consensus_committee_size\" int31)\n (req \"consensus_threshold\" int31))\n (merge_objs\n (obj7\n (req \"minimal_participation_ratio\" Ratio_repr.encoding)\n (req \"max_slashing_period\" int31)\n (req \"frozen_deposits_percentage\" int31)\n (req \"double_baking_punishment\" Tez_repr.encoding)\n (req\n \"ratio_of_frozen_deposits_slashed_per_double_endorsement\"\n Ratio_repr.encoding)\n (opt \"testnet_dictator\" Signature.Public_key_hash.encoding)\n (opt \"initial_seed\" State_hash.encoding))\n (merge_objs\n (obj3\n (req \"cache_script_size\" int31)\n (req \"cache_stake_distribution_cycles\" int8)\n (req \"cache_sampler_state_cycles\" int8))\n (merge_objs\n tx_rollup_encoding\n (merge_objs\n (obj1 (req \"dal_parametric\" dal_encoding))\n (merge_objs sc_rollup_encoding zk_rollup_encoding))))))))\n" ;
} ;
{ name = "Constants_parametric_previous_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020-2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2021-2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype dal = {\n feature_enable : bool;\n number_of_slots : int;\n number_of_shards : int;\n endorsement_lag : int;\n availability_threshold : int;\n slot_size : int;\n redundancy_factor : int;\n page_size : int;\n}\n\nval dal_encoding : dal Data_encoding.t\n\ntype tx_rollup = {\n enable : bool;\n origination_size : int;\n (* the maximum amount of bytes messages can allocate in an inbox *)\n hard_size_limit_per_inbox : int;\n (* the maximum amount of bytes one batch can allocate in an inbox *)\n hard_size_limit_per_message : int;\n (* the amount of tez to bond a tx rollup commitment *)\n commitment_bond : Tez_repr.t;\n (* the number of blocks before a tx rollup block is final *)\n finality_period : int;\n (* the maximum number of levels that can be left unfinalized\n before we stop accepting new inboxes for a tx rollup *)\n (* the minimum number of blocks to wait before removing a finalised\n commitment from the context. *)\n withdraw_period : int;\n max_inboxes_count : int;\n (* the maximum number of messages in an inbox. This bounds the\n size of a commitment. *)\n max_messages_per_inbox : int;\n (* the maximum number of finalized commitments, to ensure that\n remove_commitment is ever called *)\n max_commitments_count : int;\n (* The number of blocks used to compute the ema factor determining\n the cost per byte for new messages in the inbox. *)\n cost_per_byte_ema_factor : int;\n (* Tickets are transmitted in batches in the\n [Tx_rollup_dispatch_tickets] operation.\n\n The semantics is that this operation is used to\n concretize the withdraw orders emitted by the layer-2,\n one layer-1 operation per messages of an\n inbox. Therefore, it is of significant importance that\n a valid batch does not produce a list of withdraw\n orders which could not fit in a layer-1 operation.\n\n With these values, at least 2048 bytes remain available\n to store the rest of the operands of\n [Tx_rollup_dispatch_tickets] (in practice, even more,\n because we overapproximate the size of tickets). So we\n are safe. *)\n max_ticket_payload_size : int;\n max_withdrawals_per_batch : int;\n (* The maximum size, in bytes, of a Merkle proof. Operations which would\n require proofs larger than this should be no-ops. *)\n rejection_max_proof_size : int;\n sunset_level : int32;\n}\n\ntype sc_rollup = {\n enable : bool;\n origination_size : int;\n challenge_window_in_blocks : int;\n max_number_of_messages_per_commitment_period : int;\n stake_amount : Tez_repr.t;\n (* The period with which commitments are made. *)\n commitment_period_in_blocks : int;\n (* The maximum depth of a staker's position - chosen alongside\n [commitment_period_in_blocks] to prevent the cost\n of a staker's commitments' storage being greater than their deposit. *)\n max_lookahead_in_blocks : int32;\n (* Maximum number of active outbox levels allowed. An outbox level is active\n if it has an associated record of applied messages. *)\n max_active_outbox_levels : int32;\n max_outbox_messages_per_level : int;\n (* The default number of required sections in a dissection *)\n number_of_sections_in_dissection : int;\n (* The timeout period for a player in a refutation game.\n\n Timeout logic is similar to a chess clock. Each player starts with the same\n timeout = [timeout_period_in_blocks]. Each game move updates the timeout of\n the current player by decreasing it by the amount of time she took to play,\n i.e. number of blocks since the opponent last move. See\n {!Sc_rollup_game_repr.timeout} and\n {!Sc_rollup_refutation_storage.game_move} to see the implementation.\n\n Because of that [timeout_period_in_blocks] must be at least half the upper\n bound number of blocks needed for a game to finish. This bound is\n correlated to the maximum distance allowed between the first and last tick\n of a dissection. For example, when the maximum distance allowed is half the\n total distance [(last_tick - last_tick) / 2] then bound is [Log^2\n (Int64.max_int) + 2 = 65]. See {!Sc_rollup_game_repr.check_dissection} for\n more information on the dissection logic. *)\n timeout_period_in_blocks : int;\n (* The maximum number of cemented commitments stored for a sc rollup. *)\n max_number_of_stored_cemented_commitments : int;\n}\n\ntype zk_rollup = {\n enable : bool;\n origination_size : int;\n (* Minimum number of pending operations that can be processed by a ZKRU\n update, if available.\n If the length of the pending list is less than [min_pending_to_process],\n then an update needs to process all pending operations to be valid.\n That is, every update must process at least\n [min(length pending_list, min_pending_to_process)] pending operations. *)\n min_pending_to_process : int;\n}\n\ntype t = {\n preserved_cycles : int;\n blocks_per_cycle : int32;\n blocks_per_commitment : int32;\n nonce_revelation_threshold : int32;\n blocks_per_stake_snapshot : int32;\n cycles_per_voting_period : int32;\n hard_gas_limit_per_operation : Gas_limit_repr.Arith.integral;\n hard_gas_limit_per_block : Gas_limit_repr.Arith.integral;\n proof_of_work_threshold : int64;\n minimal_stake : Tez_repr.t;\n vdf_difficulty : int64;\n seed_nonce_revelation_tip : Tez_repr.t;\n origination_size : int;\n baking_reward_fixed_portion : Tez_repr.t;\n baking_reward_bonus_per_slot : Tez_repr.t;\n endorsing_reward_per_slot : Tez_repr.t;\n cost_per_byte : Tez_repr.t;\n hard_storage_limit_per_operation : Z.t;\n quorum_min : int32;\n (* in centile of a percentage *)\n quorum_max : int32;\n min_proposal_quorum : int32;\n liquidity_baking_subsidy : Tez_repr.t;\n liquidity_baking_toggle_ema_threshold : int32;\n max_operations_time_to_live : int;\n minimal_block_delay : Period_repr.t;\n delay_increment_per_round : Period_repr.t;\n minimal_participation_ratio : Ratio_repr.t;\n consensus_committee_size : int;\n (* in slots *)\n consensus_threshold : int;\n (* in slots *)\n max_slashing_period : int;\n (* in cycles *)\n frozen_deposits_percentage : int;\n (* that is, (100 * delegated tz / own tz) *)\n double_baking_punishment : Tez_repr.t;\n ratio_of_frozen_deposits_slashed_per_double_endorsement : Ratio_repr.t;\n testnet_dictator : Signature.Public_key_hash.t option;\n initial_seed : State_hash.t option;\n cache_script_size : int;\n (* in bytes *)\n cache_stake_distribution_cycles : int;\n (* in cycles *)\n cache_sampler_state_cycles : int;\n (* in cycles *)\n tx_rollup : tx_rollup;\n dal : dal;\n sc_rollup : sc_rollup;\n zk_rollup : zk_rollup;\n}\n\nval encoding : t Data_encoding.encoding\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020-2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2021-2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype dal = {\n feature_enable : bool;\n number_of_slots : int;\n number_of_shards : int;\n endorsement_lag : int;\n availability_threshold : int;\n slot_size : int;\n redundancy_factor : int;\n page_size : int;\n}\n\nlet dal_encoding =\n let open Data_encoding in\n conv\n (fun {\n feature_enable;\n number_of_slots;\n number_of_shards;\n endorsement_lag;\n availability_threshold;\n slot_size;\n redundancy_factor;\n page_size;\n } ->\n ( feature_enable,\n number_of_slots,\n number_of_shards,\n endorsement_lag,\n availability_threshold,\n slot_size,\n redundancy_factor,\n page_size ))\n (fun ( feature_enable,\n number_of_slots,\n number_of_shards,\n endorsement_lag,\n availability_threshold,\n slot_size,\n redundancy_factor,\n page_size ) ->\n {\n feature_enable;\n number_of_slots;\n number_of_shards;\n endorsement_lag;\n availability_threshold;\n slot_size;\n redundancy_factor;\n page_size;\n })\n (obj8\n (req \"feature_enable\" Data_encoding.bool)\n (req \"number_of_slots\" Data_encoding.int16)\n (req \"number_of_shards\" Data_encoding.int16)\n (req \"endorsement_lag\" Data_encoding.int16)\n (req \"availability_threshold\" Data_encoding.int16)\n (req \"slot_size\" Data_encoding.int31)\n (req \"redundancy_factor\" Data_encoding.uint8)\n (req \"page_size\" Data_encoding.uint16))\n\n(* The encoded representation of this type is stored in the context as\n bytes. Changing the encoding, or the value of these constants from\n the previous protocol may break the context migration, or (even\n worse) yield an incorrect context after migration.\n\n If you change this encoding compared to `Constants_parametric_previous_repr.t`,\n you should ensure that there is a proper migration of the constants\n during context migration. See: `Raw_context.prepare_first_block` *)\n\ntype tx_rollup = {\n enable : bool;\n origination_size : int;\n hard_size_limit_per_inbox : int;\n hard_size_limit_per_message : int;\n commitment_bond : Tez_repr.t;\n finality_period : int;\n withdraw_period : int;\n max_inboxes_count : int;\n max_messages_per_inbox : int;\n max_commitments_count : int;\n cost_per_byte_ema_factor : int;\n max_ticket_payload_size : int;\n max_withdrawals_per_batch : int;\n rejection_max_proof_size : int;\n sunset_level : int32;\n}\n\ntype sc_rollup = {\n enable : bool;\n origination_size : int;\n challenge_window_in_blocks : int;\n max_number_of_messages_per_commitment_period : int;\n stake_amount : Tez_repr.t;\n commitment_period_in_blocks : int;\n max_lookahead_in_blocks : int32;\n max_active_outbox_levels : int32;\n max_outbox_messages_per_level : int;\n number_of_sections_in_dissection : int;\n timeout_period_in_blocks : int;\n max_number_of_stored_cemented_commitments : int;\n}\n\ntype zk_rollup = {\n enable : bool;\n origination_size : int;\n min_pending_to_process : int;\n}\n\ntype t = {\n preserved_cycles : int;\n blocks_per_cycle : int32;\n blocks_per_commitment : int32;\n nonce_revelation_threshold : int32;\n blocks_per_stake_snapshot : int32;\n cycles_per_voting_period : int32;\n hard_gas_limit_per_operation : Gas_limit_repr.Arith.integral;\n hard_gas_limit_per_block : Gas_limit_repr.Arith.integral;\n proof_of_work_threshold : int64;\n minimal_stake : Tez_repr.t;\n vdf_difficulty : int64;\n seed_nonce_revelation_tip : Tez_repr.t;\n origination_size : int;\n baking_reward_fixed_portion : Tez_repr.t;\n baking_reward_bonus_per_slot : Tez_repr.t;\n endorsing_reward_per_slot : Tez_repr.t;\n cost_per_byte : Tez_repr.t;\n hard_storage_limit_per_operation : Z.t;\n quorum_min : int32;\n quorum_max : int32;\n min_proposal_quorum : int32;\n liquidity_baking_subsidy : Tez_repr.t;\n liquidity_baking_toggle_ema_threshold : int32;\n max_operations_time_to_live : int;\n minimal_block_delay : Period_repr.t;\n delay_increment_per_round : Period_repr.t;\n minimal_participation_ratio : Ratio_repr.t;\n consensus_committee_size : int;\n consensus_threshold : int;\n max_slashing_period : int;\n frozen_deposits_percentage : int;\n double_baking_punishment : Tez_repr.t;\n ratio_of_frozen_deposits_slashed_per_double_endorsement : Ratio_repr.t;\n testnet_dictator : Signature.Public_key_hash.t option;\n initial_seed : State_hash.t option;\n (* If a new cache is added, please also modify the\n [cache_layout_size] value. *)\n cache_script_size : int;\n cache_stake_distribution_cycles : int;\n cache_sampler_state_cycles : int;\n tx_rollup : tx_rollup;\n dal : dal;\n sc_rollup : sc_rollup;\n zk_rollup : zk_rollup;\n}\n\nlet tx_rollup_encoding =\n let open Data_encoding in\n conv\n (fun (c : tx_rollup) ->\n ( ( c.enable,\n c.origination_size,\n c.hard_size_limit_per_inbox,\n c.hard_size_limit_per_message,\n c.max_withdrawals_per_batch,\n c.commitment_bond,\n c.finality_period,\n c.withdraw_period,\n c.max_inboxes_count,\n c.max_messages_per_inbox ),\n ( c.max_commitments_count,\n c.cost_per_byte_ema_factor,\n c.max_ticket_payload_size,\n c.rejection_max_proof_size,\n c.sunset_level ) ))\n (fun ( ( tx_rollup_enable,\n tx_rollup_origination_size,\n tx_rollup_hard_size_limit_per_inbox,\n tx_rollup_hard_size_limit_per_message,\n tx_rollup_max_withdrawals_per_batch,\n tx_rollup_commitment_bond,\n tx_rollup_finality_period,\n tx_rollup_withdraw_period,\n tx_rollup_max_inboxes_count,\n tx_rollup_max_messages_per_inbox ),\n ( tx_rollup_max_commitments_count,\n tx_rollup_cost_per_byte_ema_factor,\n tx_rollup_max_ticket_payload_size,\n tx_rollup_rejection_max_proof_size,\n tx_rollup_sunset_level ) ) ->\n {\n enable = tx_rollup_enable;\n origination_size = tx_rollup_origination_size;\n hard_size_limit_per_inbox = tx_rollup_hard_size_limit_per_inbox;\n hard_size_limit_per_message = tx_rollup_hard_size_limit_per_message;\n max_withdrawals_per_batch = tx_rollup_max_withdrawals_per_batch;\n commitment_bond = tx_rollup_commitment_bond;\n finality_period = tx_rollup_finality_period;\n withdraw_period = tx_rollup_withdraw_period;\n max_inboxes_count = tx_rollup_max_inboxes_count;\n max_messages_per_inbox = tx_rollup_max_messages_per_inbox;\n max_commitments_count = tx_rollup_max_commitments_count;\n cost_per_byte_ema_factor = tx_rollup_cost_per_byte_ema_factor;\n max_ticket_payload_size = tx_rollup_max_ticket_payload_size;\n rejection_max_proof_size = tx_rollup_rejection_max_proof_size;\n sunset_level = tx_rollup_sunset_level;\n })\n (merge_objs\n (obj10\n (req \"tx_rollup_enable\" bool)\n (req \"tx_rollup_origination_size\" int31)\n (req \"tx_rollup_hard_size_limit_per_inbox\" int31)\n (req \"tx_rollup_hard_size_limit_per_message\" int31)\n (req \"tx_rollup_max_withdrawals_per_batch\" int31)\n (req \"tx_rollup_commitment_bond\" Tez_repr.encoding)\n (req \"tx_rollup_finality_period\" int31)\n (req \"tx_rollup_withdraw_period\" int31)\n (req \"tx_rollup_max_inboxes_count\" int31)\n (req \"tx_rollup_max_messages_per_inbox\" int31))\n (obj5\n (req \"tx_rollup_max_commitments_count\" int31)\n (req \"tx_rollup_cost_per_byte_ema_factor\" int31)\n (req \"tx_rollup_max_ticket_payload_size\" int31)\n (req \"tx_rollup_rejection_max_proof_size\" int31)\n (req \"tx_rollup_sunset_level\" int32)))\n\nlet sc_rollup_encoding =\n let open Data_encoding in\n conv\n (fun (c : sc_rollup) ->\n ( ( c.enable,\n c.origination_size,\n c.challenge_window_in_blocks,\n c.max_number_of_messages_per_commitment_period,\n c.stake_amount,\n c.commitment_period_in_blocks,\n c.max_lookahead_in_blocks,\n c.max_active_outbox_levels,\n c.max_outbox_messages_per_level,\n c.number_of_sections_in_dissection ),\n (c.timeout_period_in_blocks, c.max_number_of_stored_cemented_commitments)\n ))\n (fun ( ( sc_rollup_enable,\n sc_rollup_origination_size,\n sc_rollup_challenge_window_in_blocks,\n sc_rollup_max_number_of_messages_per_commitment_period,\n sc_rollup_stake_amount,\n sc_rollup_commitment_period_in_blocks,\n sc_rollup_max_lookahead_in_blocks,\n sc_rollup_max_active_outbox_levels,\n sc_rollup_max_outbox_messages_per_level,\n sc_rollup_number_of_sections_in_dissection ),\n ( sc_rollup_timeout_period_in_blocks,\n sc_rollup_max_number_of_cemented_commitments ) ) ->\n {\n enable = sc_rollup_enable;\n origination_size = sc_rollup_origination_size;\n challenge_window_in_blocks = sc_rollup_challenge_window_in_blocks;\n max_number_of_messages_per_commitment_period =\n sc_rollup_max_number_of_messages_per_commitment_period;\n stake_amount = sc_rollup_stake_amount;\n commitment_period_in_blocks = sc_rollup_commitment_period_in_blocks;\n max_lookahead_in_blocks = sc_rollup_max_lookahead_in_blocks;\n max_active_outbox_levels = sc_rollup_max_active_outbox_levels;\n max_outbox_messages_per_level = sc_rollup_max_outbox_messages_per_level;\n number_of_sections_in_dissection =\n sc_rollup_number_of_sections_in_dissection;\n timeout_period_in_blocks = sc_rollup_timeout_period_in_blocks;\n max_number_of_stored_cemented_commitments =\n sc_rollup_max_number_of_cemented_commitments;\n })\n (merge_objs\n (obj10\n (req \"sc_rollup_enable\" bool)\n (req \"sc_rollup_origination_size\" int31)\n (req \"sc_rollup_challenge_window_in_blocks\" int31)\n (req \"sc_rollup_max_number_of_messages_per_commitment_period\" int31)\n (req \"sc_rollup_stake_amount\" Tez_repr.encoding)\n (req \"sc_rollup_commitment_period_in_blocks\" int31)\n (req \"sc_rollup_max_lookahead_in_blocks\" int32)\n (req \"sc_rollup_max_active_outbox_levels\" int32)\n (req \"sc_rollup_max_outbox_messages_per_level\" int31)\n (req \"sc_rollup_number_of_sections_in_dissection\" uint8))\n (obj2\n (req \"sc_rollup_timeout_period_in_blocks\" int31)\n (req \"sc_rollup_max_number_of_cemented_commitments\" int31)))\n\nlet zk_rollup_encoding =\n let open Data_encoding in\n conv\n (fun ({enable; origination_size; min_pending_to_process} : zk_rollup) ->\n (enable, origination_size, min_pending_to_process))\n (fun ( zk_rollup_enable,\n zk_rollup_origination_size,\n zk_rollup_min_pending_to_process ) ->\n {\n enable = zk_rollup_enable;\n origination_size = zk_rollup_origination_size;\n min_pending_to_process = zk_rollup_min_pending_to_process;\n })\n (obj3\n (req \"zk_rollup_enable\" bool)\n (req \"zk_rollup_origination_size\" int31)\n (req \"zk_rollup_min_pending_to_process\" int31))\n\nlet encoding =\n let open Data_encoding in\n conv\n (fun c ->\n ( ( c.preserved_cycles,\n c.blocks_per_cycle,\n c.blocks_per_commitment,\n c.nonce_revelation_threshold,\n c.blocks_per_stake_snapshot,\n c.cycles_per_voting_period,\n c.hard_gas_limit_per_operation,\n c.hard_gas_limit_per_block,\n c.proof_of_work_threshold,\n c.minimal_stake ),\n ( ( c.vdf_difficulty,\n c.seed_nonce_revelation_tip,\n c.origination_size,\n c.baking_reward_fixed_portion,\n c.baking_reward_bonus_per_slot,\n c.endorsing_reward_per_slot,\n c.cost_per_byte,\n c.hard_storage_limit_per_operation,\n c.quorum_min ),\n ( ( c.quorum_max,\n c.min_proposal_quorum,\n c.liquidity_baking_subsidy,\n c.liquidity_baking_toggle_ema_threshold,\n c.max_operations_time_to_live,\n c.minimal_block_delay,\n c.delay_increment_per_round,\n c.consensus_committee_size,\n c.consensus_threshold ),\n ( ( c.minimal_participation_ratio,\n c.max_slashing_period,\n c.frozen_deposits_percentage,\n c.double_baking_punishment,\n c.ratio_of_frozen_deposits_slashed_per_double_endorsement,\n c.testnet_dictator,\n c.initial_seed ),\n ( ( c.cache_script_size,\n c.cache_stake_distribution_cycles,\n c.cache_sampler_state_cycles ),\n (c.tx_rollup, (c.dal, (c.sc_rollup, c.zk_rollup))) ) ) ) ) ))\n (fun ( ( preserved_cycles,\n blocks_per_cycle,\n blocks_per_commitment,\n nonce_revelation_threshold,\n blocks_per_stake_snapshot,\n cycles_per_voting_period,\n hard_gas_limit_per_operation,\n hard_gas_limit_per_block,\n proof_of_work_threshold,\n minimal_stake ),\n ( ( vdf_difficulty,\n seed_nonce_revelation_tip,\n origination_size,\n baking_reward_fixed_portion,\n baking_reward_bonus_per_slot,\n endorsing_reward_per_slot,\n cost_per_byte,\n hard_storage_limit_per_operation,\n quorum_min ),\n ( ( quorum_max,\n min_proposal_quorum,\n liquidity_baking_subsidy,\n liquidity_baking_toggle_ema_threshold,\n max_operations_time_to_live,\n minimal_block_delay,\n delay_increment_per_round,\n consensus_committee_size,\n consensus_threshold ),\n ( ( minimal_participation_ratio,\n max_slashing_period,\n frozen_deposits_percentage,\n double_baking_punishment,\n ratio_of_frozen_deposits_slashed_per_double_endorsement,\n testnet_dictator,\n initial_seed ),\n ( ( cache_script_size,\n cache_stake_distribution_cycles,\n cache_sampler_state_cycles ),\n (tx_rollup, (dal, (sc_rollup, zk_rollup))) ) ) ) ) ) ->\n {\n preserved_cycles;\n blocks_per_cycle;\n blocks_per_commitment;\n nonce_revelation_threshold;\n blocks_per_stake_snapshot;\n cycles_per_voting_period;\n hard_gas_limit_per_operation;\n hard_gas_limit_per_block;\n proof_of_work_threshold;\n minimal_stake;\n vdf_difficulty;\n seed_nonce_revelation_tip;\n origination_size;\n baking_reward_fixed_portion;\n baking_reward_bonus_per_slot;\n endorsing_reward_per_slot;\n cost_per_byte;\n hard_storage_limit_per_operation;\n quorum_min;\n quorum_max;\n min_proposal_quorum;\n liquidity_baking_subsidy;\n liquidity_baking_toggle_ema_threshold;\n max_operations_time_to_live;\n minimal_block_delay;\n delay_increment_per_round;\n minimal_participation_ratio;\n max_slashing_period;\n consensus_committee_size;\n consensus_threshold;\n frozen_deposits_percentage;\n double_baking_punishment;\n ratio_of_frozen_deposits_slashed_per_double_endorsement;\n testnet_dictator;\n initial_seed;\n cache_script_size;\n cache_stake_distribution_cycles;\n cache_sampler_state_cycles;\n tx_rollup;\n dal;\n sc_rollup;\n zk_rollup;\n })\n (merge_objs\n (obj10\n (req \"preserved_cycles\" uint8)\n (req \"blocks_per_cycle\" int32)\n (req \"blocks_per_commitment\" int32)\n (req \"nonce_revelation_threshold\" int32)\n (req \"blocks_per_stake_snapshot\" int32)\n (req \"cycles_per_voting_period\" int32)\n (req\n \"hard_gas_limit_per_operation\"\n Gas_limit_repr.Arith.z_integral_encoding)\n (req\n \"hard_gas_limit_per_block\"\n Gas_limit_repr.Arith.z_integral_encoding)\n (req \"proof_of_work_threshold\" int64)\n (req \"minimal_stake\" Tez_repr.encoding))\n (merge_objs\n (obj9\n (req \"vdf_difficulty\" int64)\n (req \"seed_nonce_revelation_tip\" Tez_repr.encoding)\n (req \"origination_size\" int31)\n (req \"baking_reward_fixed_portion\" Tez_repr.encoding)\n (req \"baking_reward_bonus_per_slot\" Tez_repr.encoding)\n (req \"endorsing_reward_per_slot\" Tez_repr.encoding)\n (req \"cost_per_byte\" Tez_repr.encoding)\n (req \"hard_storage_limit_per_operation\" z)\n (req \"quorum_min\" int32))\n (merge_objs\n (obj9\n (req \"quorum_max\" int32)\n (req \"min_proposal_quorum\" int32)\n (req \"liquidity_baking_subsidy\" Tez_repr.encoding)\n (req \"liquidity_baking_toggle_ema_threshold\" int32)\n (req \"max_operations_time_to_live\" int16)\n (req \"minimal_block_delay\" Period_repr.encoding)\n (req \"delay_increment_per_round\" Period_repr.encoding)\n (req \"consensus_committee_size\" int31)\n (req \"consensus_threshold\" int31))\n (merge_objs\n (obj7\n (req \"minimal_participation_ratio\" Ratio_repr.encoding)\n (req \"max_slashing_period\" int31)\n (req \"frozen_deposits_percentage\" int31)\n (req \"double_baking_punishment\" Tez_repr.encoding)\n (req\n \"ratio_of_frozen_deposits_slashed_per_double_endorsement\"\n Ratio_repr.encoding)\n (opt \"testnet_dictator\" Signature.Public_key_hash.encoding)\n (opt \"initial_seed\" State_hash.encoding))\n (merge_objs\n (obj3\n (req \"cache_script_size\" int31)\n (req \"cache_stake_distribution_cycles\" int8)\n (req \"cache_sampler_state_cycles\" int8))\n (merge_objs\n tx_rollup_encoding\n (merge_objs\n (obj1 (req \"dal_parametric\" dal_encoding))\n (merge_objs sc_rollup_encoding zk_rollup_encoding))))))))\n" ;
} ;
{ name = "Constants_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020-2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2021-2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nval mainnet_id : Chain_id.t\n\nval fitness_version_number : string\n\nval proof_of_work_nonce_size : int\n\nval nonce_length : int\n\nval max_anon_ops_per_block : int\n\nval max_proposals_per_delegate : int\n\nval max_operation_data_length : int\n\n(** A global size limit on the size of Micheline expressions\n after expansion.\n\n We want to prevent constants from being\n used to create huge values that could potentially do damage\n if ever printed or sent over the network. We arrived at this\n number by finding the largest possible contract in terms of\n number of nodes. The number of nodes is constrained by the\n current \"max_operation_data_length\" (32768) to be ~10,000 (\n see \"large_flat_contract.tz\" in the tezt suite for the largest\n contract with constants that can be originated). As a first\n approximation, we set the node size limit to 5 times this amount. *)\nval max_micheline_node_count : int\n\n(** Same as [max_micheline_node_count] but for limiting the combined\n bytes of the strings, ints and bytes in a expanded Micheline\n expression. *)\nval max_micheline_bytes_limit : int\n\n(** Represents the maximum depth of an expression stored\n in the table after all references to other constants have\n (recursively) been expanded, where depth refers to the\n nesting of [Prim] and/or [Seq] nodes.\n\n The size was chosen arbitrarily to match the typechecker\n in [Script_ir_translator]. *)\nval max_allowed_global_constant_depth : int\n\n(** A global size limit on the size of Michelson types.\n\n The size of a type is the number of nodes in its AST\n representation. See [Script_typed_ir.TYPE_SIZE].\n *)\nval michelson_maximum_type_size : int\n\n(** A size limit for {!Sc_rollups.wrapped_proof} binary encoding. *)\nval sc_max_wrapped_proof_binary_size : int\n\n(** A limit on the size of the binary encoding for sc rollup messages:\n {!Sc_rollup_inbox_message_repr.t} and {!Sc_rollup_outbox_message_repr.t}\n*)\nval sc_rollup_message_size_limit : int\n\n(** A limit on the number of messages in a inbox level enforced in\n {!Sc_rollup_inbox_repr.t}. *)\nval sc_rollup_max_number_of_messages_per_level : Z.t\n\ntype fixed\n\nval fixed_encoding : fixed Data_encoding.encoding\n\ntype t = private {fixed : fixed; parametric : Constants_parametric_repr.t}\n\nval all_of_parametric : Constants_parametric_repr.t -> t\n\nval encoding : t Data_encoding.encoding\n\ntype error += (* `Permanent *) Invalid_protocol_constants of string\n\n(** performs some consistency checks on the protocol parameters *)\nval check_constants : Constants_parametric_repr.t -> unit tzresult\n\nmodule Generated : sig\n type t = {\n consensus_threshold : int;\n baking_reward_fixed_portion : Tez_repr.t;\n baking_reward_bonus_per_slot : Tez_repr.t;\n endorsing_reward_per_slot : Tez_repr.t;\n liquidity_baking_subsidy : Tez_repr.t;\n }\n\n (* This function is meant to be used just in lib_parameters and in the\n migration code to be sure that the parameters are consistent. *)\n val generate :\n consensus_committee_size:int -> blocks_per_minute:Ratio_repr.t -> t\nend\n\n(** For each subcache, a size limit needs to be declared once. However,\n depending how the protocol will be instantiated (sandboxed mode,\n test network, ...) we may want to change this limit. For each\n subcache, a parametric constant can be used to change the limit\n (see {!parametric}).\n\n The number of subcaches and the limits for all those subcaches form\n together what is called the [cache_layout]. *)\nval cache_layout_size : int\n\n(** The [cache_layout] depends on parametric constants. *)\nval cache_layout : Constants_parametric_repr.t -> int list\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020-2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2021-2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nlet mainnet_id = Chain_id.of_b58check_exn \"NetXdQprcVkpaWU\"\n\n(* The fitness version number was:\n - \"\\000\" until and including proto 004\n - \"\\001\" until and including proto 010\n*)\nlet fitness_version_number = \"\\002\"\n\nlet proof_of_work_nonce_size = 8\n\nlet nonce_length = 32\n\nlet max_anon_ops_per_block = 132\n\nlet max_proposals_per_delegate = 20\n\nlet max_operation_data_length = 32 * 1024 (* 32kB *)\n\nlet max_micheline_node_count = 50_000\n\nlet max_micheline_bytes_limit = 50_000\n\nlet max_allowed_global_constant_depth = 10_000\n\n(* In previous versions of the protocol, this\n [michelson_maximum_type_size] limit was set to 1000 but\n the contract input types (pair <parameter_type> <storage_type>)\n were not checked. Both components, <parameter_type> and\n <storage_type> where however checked hence it was possible to build\n types as big as 2001. *)\nlet michelson_maximum_type_size = 2001\n\n(* This constant declares the number of subcaches used by the cache\n mechanism (see {Context.Cache}). *)\nlet cache_layout_size = 3\n\n(* The {!Sc_rollups.wrapped_proof_encoding} uses unbounded sub-encodings.\n To avoid attacks through too large proofs and long decoding times on public\n nodes, we put another layer of security by restricting the maximum_size\n to [30Kb].\n\n Even if the operation size limit is currently [32Kb] (see\n {!Constants_repr.max_operation_data_length}) the node's mempool can still\n be spammed with larger proofs before detecting that the operations are\n indeed larger than the limit.\n\n By design, the proofs should be created and verified for a single tick\n which should limit the number of read/writes in the Merkle tree, and thefore,\n limit the total size of a proof. Thus, [30Kb] can be lowered once we\n have empirically observed that a valid proof can not be that large.\n\n Note that an encoded proof that is [30Kb] might still be not included\n in a valid L1 operation. The refutation operation also contains other\n information such as an inbox proof. We only put here an upper bound\n for the size.\n*)\nlet sc_max_wrapped_proof_binary_size = 30_000\n\n(* A limit on the size of the binary encoding of sc rollup messages. This limit\n depends on the assumed overhead of the proof and metadata in a manager\n operation justifying the existence of some chunk of data in the rollup state.\n The value of this constant reflects the global constant of 4KB in the WASM\n PVM specification chosen for the limit of chunks that are embedded in proofs.\n*)\nlet sc_rollup_message_size_limit = 4_096\n\n(** A limit on the number of messages per inbox level.\n\n Benchmarks have shown that proving the inclusion of the element at\n index 0 in a skip list of [1_000_000] elements is ~=6Kb large.\n*)\nlet sc_rollup_max_number_of_messages_per_level = Z.of_int 1_000_000\n\ntype fixed = unit\n\nlet fixed_encoding =\n let open Data_encoding in\n conv\n (fun () ->\n ( ( proof_of_work_nonce_size,\n nonce_length,\n max_anon_ops_per_block,\n max_operation_data_length,\n max_proposals_per_delegate,\n max_micheline_node_count,\n max_micheline_bytes_limit,\n max_allowed_global_constant_depth,\n cache_layout_size,\n michelson_maximum_type_size ),\n ( sc_max_wrapped_proof_binary_size,\n sc_rollup_message_size_limit,\n sc_rollup_max_number_of_messages_per_level ) ))\n (fun ( ( _proof_of_work_nonce_size,\n _nonce_length,\n _max_anon_ops_per_block,\n _max_operation_data_length,\n _max_proposals_per_delegate,\n _max_micheline_node_count,\n _max_micheline_bytes_limit,\n _max_allowed_global_constant_depth,\n _cache_layout_size,\n _michelson_maximum_type_size ),\n ( _sc_max_wrapped_proof_binary_size,\n _sc_rollup_message_size_limit,\n _sc_rollup_number_of_messages_per_level ) ) -> ())\n (merge_objs\n (obj10\n (req \"proof_of_work_nonce_size\" uint8)\n (req \"nonce_length\" uint8)\n (req \"max_anon_ops_per_block\" uint8)\n (req \"max_operation_data_length\" int31)\n (req \"max_proposals_per_delegate\" uint8)\n (req \"max_micheline_node_count\" int31)\n (req \"max_micheline_bytes_limit\" int31)\n (req \"max_allowed_global_constants_depth\" int31)\n (req \"cache_layout_size\" uint8)\n (req \"michelson_maximum_type_size\" uint16))\n (obj3\n (req \"smart_rollup_max_wrapped_proof_binary_size\" int31)\n (req \"smart_rollup_message_size_limit\" int31)\n (req \"smart_rollup_max_number_of_messages_per_level\" n)))\n\nlet fixed = ()\n\ntype t = {fixed : fixed; parametric : Constants_parametric_repr.t}\n\nlet all_of_parametric parametric = {fixed; parametric}\n\nlet encoding =\n let open Data_encoding in\n conv\n (fun {fixed; parametric} -> (fixed, parametric))\n (fun (fixed, parametric) -> {fixed; parametric})\n (merge_objs fixed_encoding Constants_parametric_repr.encoding)\n\ntype error += Invalid_protocol_constants of string (* `Permanent *)\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"constants.invalid_protocol_constants\"\n ~title:\"Invalid protocol constants\"\n ~description:\"The provided protocol constants are not coherent.\"\n ~pp:(fun ppf reason ->\n Format.fprintf ppf \"Invalid protocol constants: %s\" reason)\n Data_encoding.(obj1 (req \"reason\" @@ string Plain))\n (function Invalid_protocol_constants reason -> Some reason | _ -> None)\n (fun reason -> Invalid_protocol_constants reason)\n\nlet check_constants constants =\n let open Constants_parametric_repr in\n error_unless\n Period_repr.(constants.minimal_block_delay > zero)\n (Invalid_protocol_constants\n \"The minimal block delay must be greater than zero\")\n >>? fun () ->\n error_unless\n Period_repr.(constants.delay_increment_per_round > zero)\n (Invalid_protocol_constants\n \"The delay increment per round must be greater than zero\")\n >>? fun () ->\n error_unless\n Compare.Int.(constants.consensus_committee_size > 0)\n (Invalid_protocol_constants\n \"The consensus committee size must be strictly greater than 0.\")\n >>? fun () ->\n error_unless\n Compare.Int.(\n constants.consensus_threshold >= 0\n && constants.consensus_threshold <= constants.consensus_committee_size)\n (Invalid_protocol_constants\n \"The consensus threshold must be greater than or equal to 0 and less \\\n than or equal to the consensus commitee size.\")\n >>? fun () ->\n error_unless\n (let Ratio_repr.{numerator; denominator} =\n constants.minimal_participation_ratio\n in\n Compare.Int.(numerator >= 0 && denominator > 0))\n (Invalid_protocol_constants\n \"The minimal participation ratio must be a non-negative valid ratio.\")\n >>? fun () ->\n error_unless\n Compare.Int.(\n constants.minimal_participation_ratio.numerator\n <= constants.minimal_participation_ratio.denominator)\n (Invalid_protocol_constants\n \"The minimal participation ratio must be less than or equal to 100%.\")\n >>? fun () ->\n error_unless\n Compare.Int.(constants.max_slashing_period > 0)\n (Invalid_protocol_constants\n \"The unfreeze delay must be strictly greater than 0.\")\n >>? fun () ->\n (* The [frozen_deposits_percentage] should be a percentage *)\n error_unless\n Compare.Int.(\n constants.frozen_deposits_percentage > 0\n && constants.frozen_deposits_percentage <= 100)\n (Invalid_protocol_constants\n \"The frozen percentage ratio must be strictly greater than 0 and less \\\n or equal than 100.\")\n >>? fun () ->\n error_unless\n Tez_repr.(constants.double_baking_punishment >= zero)\n (Invalid_protocol_constants\n \"The double baking punishment must be non-negative.\")\n >>? fun () ->\n error_unless\n (let Ratio_repr.{numerator; denominator} =\n constants.ratio_of_frozen_deposits_slashed_per_double_endorsement\n in\n Compare.Int.(numerator >= 0 && denominator > 0))\n (Invalid_protocol_constants\n \"The ratio of frozen deposits ratio slashed per double endorsement must \\\n be a non-negative valid ratio.\")\n >>? fun () ->\n error_unless\n (let snapshot_frequence =\n Int32.div constants.blocks_per_cycle constants.blocks_per_stake_snapshot\n in\n Compare.Int32.(\n snapshot_frequence > Int32.zero\n && snapshot_frequence < Int32.of_int (1 lsl 16)))\n (Invalid_protocol_constants\n \"The ratio blocks_per_cycle per blocks_per_stake_snapshot should be \\\n between 1 and 65535\")\n >>? fun () ->\n error_unless\n Compare.Int32.(\n constants.nonce_revelation_threshold > Int32.zero\n && constants.nonce_revelation_threshold < constants.blocks_per_cycle)\n (Invalid_protocol_constants\n \"The nonce revelation threshold must be strictly smaller than \\\n blocks_per_cycle and strictly positive.\")\n >>? fun () ->\n error_unless\n Compare.Int64.(\n let threshold = Int64.of_int32 constants.nonce_revelation_threshold in\n let block = Period_repr.to_seconds constants.minimal_block_delay in\n let ips =\n (* We reduce the ips for short blocks_per_commitment so that we have\n low difficulty during tests *)\n if Compare.Int32.(constants.blocks_per_commitment > 32l) then\n Int64.of_int 200_000\n else Int64.one\n in\n let factor = Int64.of_int 5 in\n let difficulty = Int64.(mul (mul ips factor) (mul threshold block)) in\n constants.vdf_difficulty > difficulty)\n (Invalid_protocol_constants\n \"The VDF difficulty must be strictly greater than the product of the \\\n nonce_revelation_threshold, the minimial_block_delay, a benchmark of \\\n modulo squaring in class groups and a security threshold.\")\n >>? fun () ->\n error_unless\n Compare.Int.(constants.sc_rollup.origination_size >= 0)\n (Invalid_protocol_constants\n \"The smart rollup origination size must be non-negative.\")\n >>? fun () ->\n error_unless\n Compare.Int.(constants.sc_rollup.challenge_window_in_blocks >= 0)\n (Invalid_protocol_constants\n \"The smart rollup challenge window in blocks must be non-negative.\")\n >>? fun () ->\n error_unless\n Tez_repr.(constants.sc_rollup.stake_amount >= zero)\n (Invalid_protocol_constants\n \"The smart rollup max stake amount must be non-negative.\")\n >>? fun () ->\n error_unless\n Compare.Int.(constants.sc_rollup.commitment_period_in_blocks > 0)\n (Invalid_protocol_constants\n \"The smart rollup commitment period in blocks must be strictly greater \\\n than 0.\")\n >>? fun () ->\n error_unless\n (let sc_rollup_max_lookahead_in_blocks =\n constants.sc_rollup.max_lookahead_in_blocks\n in\n Compare.Int32.(\n sc_rollup_max_lookahead_in_blocks\n > Int32.of_int constants.sc_rollup.commitment_period_in_blocks\n && (* Check that [smart_rollup_challenge_window_in_blocks <\n smart_rollup_max_lookahead_in_blocks]. Otherwise committers would be\n forced to commit at an artificially slow rate, affecting the\n throughput of the rollup. *)\n sc_rollup_max_lookahead_in_blocks\n > Int32.of_int constants.sc_rollup.challenge_window_in_blocks))\n (Invalid_protocol_constants\n \"The smart rollup max lookahead in blocks must be greater than \\\n [smart_rollup_commitment_period_in_blocks] and \\\n [smart_rollup_challenge_window_in_blocks].\")\n >>? fun () ->\n error_unless\n Compare.Int.(\n constants.dal.number_of_slots > 0 && constants.dal.number_of_slots <= 256)\n (Invalid_protocol_constants\n \"The number of data availability slot must be between 1 and 256\")\n >>? fun () ->\n error_unless\n Compare.Int.(\n constants.sc_rollup.max_number_of_stored_cemented_commitments > 0)\n (Invalid_protocol_constants\n \"The number of maximum stored cemented commitments must be strictly \\\n positive\")\n >>? fun () -> Result.return_unit\n\nmodule Generated = struct\n type t = {\n consensus_threshold : int;\n baking_reward_fixed_portion : Tez_repr.t;\n baking_reward_bonus_per_slot : Tez_repr.t;\n endorsing_reward_per_slot : Tez_repr.t;\n liquidity_baking_subsidy : Tez_repr.t;\n }\n\n let generate ~consensus_committee_size ~blocks_per_minute =\n let consensus_threshold = (consensus_committee_size * 2 / 3) + 1 in\n (* As in previous protocols, we set the maximum total rewards per minute to\n be 80 tez. *)\n let rewards_per_minute = Tez_repr.(mul_exn one 80) in\n let rewards_per_block =\n Ratio_repr.(\n Tez_repr.(\n div_exn\n (mul_exn rewards_per_minute blocks_per_minute.denominator)\n blocks_per_minute.numerator))\n in\n let rewards_half = Tez_repr.(div_exn rewards_per_block 2) in\n let rewards_quarter = Tez_repr.(div_exn rewards_per_block 4) in\n let bonus_committee_size = consensus_committee_size - consensus_threshold in\n {\n consensus_threshold;\n baking_reward_fixed_portion =\n (if Compare.Int.(bonus_committee_size <= 0) then\n (* a fortiori, consensus_committee_size < 4 *)\n rewards_half\n else rewards_quarter);\n baking_reward_bonus_per_slot =\n (if Compare.Int.(bonus_committee_size <= 0) then Tez_repr.zero\n else Tez_repr.div_exn rewards_quarter bonus_committee_size);\n endorsing_reward_per_slot =\n Tez_repr.div_exn rewards_half consensus_committee_size;\n liquidity_baking_subsidy = Tez_repr.div_exn rewards_per_block 16;\n }\nend\n\nlet cache_layout p =\n Constants_parametric_repr.\n [\n p.cache_script_size;\n p.cache_stake_distribution_cycles;\n p.cache_sampler_state_cycles;\n ]\n" ;
} ;
{ name = "Raw_level_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** The shell's notion of a level: an integer indicating the number of blocks\n since genesis: genesis is 0, all other blocks have increasing levels from\n there. *)\ntype t\n\ntype raw_level = t\n\nmodule Set : Set.S with type elt = t\n\nmodule Map : Map.S with type key = t\n\n(** @raise Invalid_argument when the level to encode is not positive *)\nval encoding : raw_level Data_encoding.t\n\nval rpc_arg : raw_level RPC_arg.arg\n\nval pp : Format.formatter -> raw_level -> unit\n\ninclude Compare.S with type t := raw_level\n\nval to_int32 : raw_level -> int32\n\nval to_int32_non_negative : raw_level -> Bounded.Non_negative_int32.t\n\n(** @raise Invalid_argument when the level to encode is negative *)\nval of_int32_exn : int32 -> raw_level\n\n(** Can trigger Unexpected_level error when the level to encode is negative *)\nval of_int32 : int32 -> raw_level tzresult\n\nval of_int32_non_negative : Bounded.Non_negative_int32.t -> raw_level\n\nval diff : raw_level -> raw_level -> int32\n\nval root : raw_level\n\nval succ : raw_level -> raw_level\n\nval pred : raw_level -> raw_level option\n\n(** [add l i] i must be positive *)\nval add : raw_level -> int -> raw_level\n\n(** [sub l i] i must be positive *)\nval sub : raw_level -> int -> raw_level option\n\nmodule Index : Storage_description.INDEX with type t = raw_level\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t = int32\n\ntype raw_level = t\n\ninclude (Compare.Int32 : Compare.S with type t := t)\n\nmodule Set = Set.Make (Compare.Int32)\nmodule Map = Map.Make (Compare.Int32)\n\nlet pp ppf level = Format.fprintf ppf \"%ld\" level\n\nlet rpc_arg =\n let construct raw_level = Int32.to_string raw_level in\n let destruct str =\n Int32.of_string_opt str |> Option.to_result ~none:\"Cannot parse level\"\n in\n RPC_arg.make\n ~descr:\"A level integer\"\n ~name:\"block_level\"\n ~construct\n ~destruct\n ()\n\nlet root = 0l\n\nlet succ = Int32.succ\n\nlet add l i =\n assert (Compare.Int.(i >= 0)) ;\n Int32.add l (Int32.of_int i)\n\nlet sub l i =\n assert (Compare.Int.(i >= 0)) ;\n let res = Int32.sub l (Int32.of_int i) in\n if Compare.Int32.(res >= 0l) then Some res else None\n\nlet pred l = if l = 0l then None else Some (Int32.pred l)\n\nlet diff = Int32.sub\n\nlet to_int32 l = l\n\nlet to_int32_non_negative l =\n match Bounded.Non_negative_int32.of_value l with\n | Some x -> x\n | _ -> assert false (* invariant: raw_levels are non-negative *)\n\ntype error += Unexpected_level of Int32.t (* `Permanent *)\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"unexpected_level\"\n ~title:\"Unexpected level\"\n ~description:\"Level must be non-negative.\"\n ~pp:(fun ppf l ->\n Format.fprintf\n ppf\n \"The level is %s but should be non-negative.\"\n (Int32.to_string l))\n Data_encoding.(obj1 (req \"level\" int32))\n (function Unexpected_level l -> Some l | _ -> None)\n (fun l -> Unexpected_level l)\n\nlet of_int32 l =\n if Compare.Int32.(l >= 0l) then ok l else error (Unexpected_level l)\n\nlet of_int32_exn l =\n match of_int32 l with\n | Ok l -> l\n | Error _ -> invalid_arg \"Level_repr.of_int32\"\n\nlet of_int32_non_negative l =\n match of_int32 (Bounded.Non_negative_int32.to_value l) with\n | Ok l -> l\n | Error _ -> assert false (* invariant: raw_levels are non-negative *)\n\nlet encoding =\n Data_encoding.conv_with_guard\n to_int32\n (fun l ->\n match of_int32 l with\n | Ok l -> Ok l\n | Error _ -> Error \"Level_repr.of_int32\")\n Data_encoding.int32\n\nmodule Index = struct\n type t = raw_level\n\n let path_length = 1\n\n let to_path level l = Int32.to_string level :: l\n\n let of_path = function [s] -> Int32.of_string_opt s | _ -> None\n\n let rpc_arg = rpc_arg\n\n let encoding = encoding\n\n let compare = compare\nend\n" ;
} ;
{ name = "Fitness_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2020 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error +=\n | (* `Permanent *) Invalid_fitness\n | (* `Permanent *) Wrong_fitness\n | (* `Permanent *) Outdated_fitness\n | (* `Permanent *)\n Locked_round_not_less_than_round of {\n round : Round_repr.t;\n locked_round : Round_repr.t;\n }\n\ntype t\n\nval encoding : t Data_encoding.t\n\nval pp : Format.formatter -> t -> unit\n\nval create :\n level:Raw_level_repr.t ->\n locked_round:Round_repr.t option ->\n predecessor_round:Round_repr.t ->\n round:Round_repr.t ->\n t tzresult\n\nval create_without_locked_round :\n level:Raw_level_repr.t ->\n predecessor_round:Round_repr.t ->\n round:Round_repr.t ->\n t\n\nval to_raw : t -> Fitness.t\n\n(** Returns the corresponding protocol fitness if the shell fitness has\n the expected version, given by\n Constants_repr.fitness_version_number. If the fitness' version is\n from a previous protocol version, then it raises an \"outdated\n fitness\" error. If the fitness version is higher then\n it raises an \"invalid fitness\" error. *)\nval from_raw : Fitness.t -> t tzresult\n\n(** Returns the round from a raw fitness. If the fitness is from a\n previous protocol, the returned value will be Round.zero. *)\nval round_from_raw : Fitness.t -> Round_repr.t tzresult\n\n(** Returns the predecessor round from a raw fitness. If the fitness\n is from a previous protocol, the returned value will be Round.zero. *)\nval predecessor_round_from_raw : Fitness.t -> Round_repr.t tzresult\n\n(** Validate only the part of the fitness for which information are\n available during begin_application *)\nval check_except_locked_round :\n t -> level:Raw_level_repr.t -> predecessor_round:Round_repr.t -> unit tzresult\n\n(** Validate the locked_round component of the fitness, which could\n not be validated during begin_application. *)\nval check_locked_round : t -> locked_round:Round_repr.t option -> unit tzresult\n\nval level : t -> Raw_level_repr.t\n\nval round : t -> Round_repr.t\n\nval locked_round : t -> Round_repr.t option\n\nval predecessor_round : t -> Round_repr.t\n\n(**/**)\n\nmodule Internal_for_tests : sig\n (** uses a lexicographic order relation for [level, locked_round,\n -predecessor_round, round] *)\n val compare : t -> t -> int\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t = {\n level : Raw_level_repr.t;\n locked_round : Round_repr.t option;\n predecessor_round : Round_repr.t;\n (* by convention, predecessor_round is 0 in case of protocol migration *)\n round : Round_repr.t;\n}\n\nlet encoding =\n let open Data_encoding in\n def\n \"fitness\"\n (conv_with_guard\n (fun {level; locked_round; predecessor_round; round} ->\n (level, locked_round, predecessor_round, round))\n (fun (level, locked_round, predecessor_round, round) ->\n match locked_round with\n | None -> ok {level; locked_round; predecessor_round; round}\n | Some locked_round_val ->\n if Round_repr.(round <= locked_round_val) then\n Error \"Locked round must be smaller than round.\"\n else ok {level; locked_round; predecessor_round; round})\n (obj4\n (req \"level\" Raw_level_repr.encoding)\n (req \"locked_round\" (option Round_repr.encoding))\n (req \"predecessor_round\" Round_repr.encoding)\n (req \"round\" Round_repr.encoding)))\n\nlet pp ppf f =\n let minus_sign =\n if Round_repr.(f.predecessor_round = Round_repr.zero) then \"\" else \"-\"\n in\n let locked_round ppf locked_round =\n match locked_round with\n | None -> Format.pp_print_string ppf \"unlocked\"\n | Some round -> Format.fprintf ppf \"locked: %a\" Round_repr.pp round\n in\n Format.fprintf\n ppf\n \"(%a, %a, %s%a, %a)\"\n Raw_level_repr.pp\n f.level\n locked_round\n f.locked_round\n minus_sign\n Round_repr.pp\n f.predecessor_round\n Round_repr.pp\n f.round\n\ntype error +=\n | (* `Permanent *) Invalid_fitness\n | (* `Permanent *) Wrong_fitness\n | (* `Permanent *) Outdated_fitness\n | (* `Permanent *)\n Locked_round_not_less_than_round of {\n round : Round_repr.t;\n locked_round : Round_repr.t;\n }\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"invalid_fitness\"\n ~title:\"Invalid fitness\"\n ~description:\n \"Fitness representation should be exactly 4 times 4 bytes long.\"\n ~pp:(fun ppf () -> Format.fprintf ppf \"Invalid fitness\")\n Data_encoding.empty\n (function Invalid_fitness -> Some () | _ -> None)\n (fun () -> Invalid_fitness) ;\n register_error_kind\n `Permanent\n ~id:\"wrong_fitness\"\n ~title:\"Wrong fitness\"\n ~description:\"Wrong fitness.\"\n ~pp:(fun ppf () -> Format.fprintf ppf \"Wrong fitness.\")\n Data_encoding.empty\n (function Wrong_fitness -> Some () | _ -> None)\n (fun () -> Wrong_fitness) ;\n register_error_kind\n `Permanent\n ~id:\"outdated_fitness\"\n ~title:\"Outdated fitness\"\n ~description:\"Outdated fitness: referring to a previous version\"\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"Outdated fitness: referring to a previous version.\")\n Data_encoding.empty\n (function Outdated_fitness -> Some () | _ -> None)\n (fun () -> Outdated_fitness) ;\n register_error_kind\n `Permanent\n ~id:\"locked_round_not_less_than_round\"\n ~title:\"Locked round not smaller than round\"\n ~description:\"The round is smaller than or equal to the locked round.\"\n ~pp:(fun ppf (round, locked_round) ->\n Format.fprintf\n ppf\n \"Incorrect fitness: round %a is less than or equal to locked round %a.\"\n Round_repr.pp\n round\n Round_repr.pp\n locked_round)\n Data_encoding.(\n obj2\n (req \"round\" Round_repr.encoding)\n (req \"locked_round\" Round_repr.encoding))\n (function\n | Locked_round_not_less_than_round {round; locked_round} ->\n Some (round, locked_round)\n | _ -> None)\n (fun (round, locked_round) ->\n Locked_round_not_less_than_round {round; locked_round})\n\nlet create_without_locked_round ~level ~predecessor_round ~round =\n {level; locked_round = None; predecessor_round; round}\n\nlet create ~level ~locked_round ~predecessor_round ~round =\n match locked_round with\n | None -> ok {level; locked_round; predecessor_round; round}\n | Some locked_round_val ->\n error_when\n Round_repr.(round <= locked_round_val)\n (Locked_round_not_less_than_round\n {round; locked_round = locked_round_val})\n >>? fun () -> ok {level; locked_round; predecessor_round; round}\n\nlet int32_to_bytes i =\n let b = Bytes.make 4 '\\000' in\n TzEndian.set_int32 b 0 i ;\n b\n\nlet int32_of_bytes b =\n if Compare.Int.(Bytes.length b <> 4) then error Invalid_fitness\n else ok (TzEndian.get_int32 b 0)\n\n(* Locked round is an option. And we want None to be smaller than any other\n value. The way the shell handles the order makes the empty Bytes smaller\n than any other *)\nlet locked_round_to_bytes = function\n | None -> Bytes.empty\n | Some locked_round -> int32_to_bytes (Round_repr.to_int32 locked_round)\n\nlet locked_round_of_bytes b =\n match Bytes.length b with\n | 0 -> ok None\n | 4 -> Round_repr.of_int32 (TzEndian.get_int32 b 0) >>? fun r -> ok (Some r)\n | _ -> error Invalid_fitness\n\nlet predecessor_round_of_bytes neg_predecessor_round =\n int32_of_bytes neg_predecessor_round >>? fun neg_predecessor_round ->\n Round_repr.of_int32 @@ Int32.pred (Int32.neg neg_predecessor_round)\n\nlet round_of_bytes round = int32_of_bytes round >>? Round_repr.of_int32\n\nlet to_raw {level; locked_round; predecessor_round; round} =\n [\n Bytes.of_string Constants_repr.fitness_version_number;\n int32_to_bytes (Raw_level_repr.to_int32 level);\n locked_round_to_bytes locked_round;\n int32_to_bytes\n (Int32.pred (Int32.neg (Round_repr.to_int32 predecessor_round)));\n int32_to_bytes (Round_repr.to_int32 round);\n ]\n\nlet from_raw = function\n | [version; level; locked_round; neg_predecessor_round; round]\n when Compare.String.(\n Bytes.to_string version = Constants_repr.fitness_version_number) ->\n int32_of_bytes level >>? Raw_level_repr.of_int32 >>? fun level ->\n locked_round_of_bytes locked_round >>? fun locked_round ->\n predecessor_round_of_bytes neg_predecessor_round\n >>? fun predecessor_round ->\n round_of_bytes round >>? fun round ->\n create ~level ~locked_round ~predecessor_round ~round\n | [version; _]\n when Compare.String.(\n Bytes.to_string version < Constants_repr.fitness_version_number) ->\n error Outdated_fitness\n | [] (* genesis fitness *) -> error Outdated_fitness\n | _ -> error Invalid_fitness\n\nlet round_from_raw = function\n | [version; _level; _locked_round; _neg_predecessor_round; round]\n when Compare.String.(\n Bytes.to_string version = Constants_repr.fitness_version_number) ->\n round_of_bytes round\n | [version; _]\n when Compare.String.(\n Bytes.to_string version < Constants_repr.fitness_version_number) ->\n ok Round_repr.zero\n | [] (* genesis fitness *) -> ok Round_repr.zero\n | _ -> error Invalid_fitness\n\nlet predecessor_round_from_raw = function\n | [version; _level; _locked_round; neg_predecessor_round; _round]\n when Compare.String.(\n Bytes.to_string version = Constants_repr.fitness_version_number) ->\n predecessor_round_of_bytes neg_predecessor_round\n | [version; _]\n when Compare.String.(\n Bytes.to_string version < Constants_repr.fitness_version_number) ->\n ok Round_repr.zero\n | [] (* genesis fitness *) -> ok Round_repr.zero\n | _ -> error Invalid_fitness\n\nlet check_except_locked_round fitness ~level ~predecessor_round =\n let {\n level = expected_level;\n locked_round = _;\n predecessor_round = expected_predecessor_round;\n round = _;\n } =\n fitness\n in\n let correct =\n Raw_level_repr.(level = expected_level)\n && Round_repr.(predecessor_round = expected_predecessor_round)\n in\n error_unless correct Wrong_fitness\n\nlet check_locked_round fitness ~locked_round =\n let {\n level = _;\n locked_round = expected_locked_round;\n predecessor_round = _;\n round = _;\n } =\n fitness\n in\n let correct =\n match (locked_round, expected_locked_round) with\n | None, None -> true\n | Some _, None | None, Some _ -> false\n | Some v, Some v' -> Round_repr.(v = v')\n in\n error_unless correct Wrong_fitness\n\nlet level fitness = fitness.level\n\nlet round fitness = fitness.round\n\nlet locked_round fitness = fitness.locked_round\n\nlet predecessor_round fitness = fitness.predecessor_round\n\nmodule Internal_for_tests = struct\n module ListInt32Compare = Compare.List (Compare.Int32)\n\n let compare f ff =\n let unopt l =\n match l with Some l -> Round_repr.to_int32 l | None -> -1l\n in\n let to_list {level; locked_round; predecessor_round; round} =\n Int32.\n [\n Raw_level_repr.to_int32 level;\n unopt locked_round;\n neg (Round_repr.to_int32 predecessor_round);\n Round_repr.to_int32 round;\n ]\n in\n ListInt32Compare.compare (to_list f) (to_list ff)\nend\n" ;
} ;
{ name = "Cycle_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module provides a type and functions to manipulate cycle numbers.\n\n Invariant: cycle numbers are always positive. *)\n\ntype t\n\ntype cycle = t\n\ninclude Compare.S with type t := t\n\nval encoding : cycle Data_encoding.t\n\nval rpc_arg : cycle RPC_arg.arg\n\nval pp : Format.formatter -> cycle -> unit\n\nval root : cycle\n\nval pred : cycle -> cycle option\n\nval add : cycle -> int -> cycle\n\nval sub : cycle -> int -> cycle option\n\nval succ : cycle -> cycle\n\nval diff : cycle -> cycle -> int32\n\n(** a ---> b = [a; ...; b] *)\nval ( ---> ) : cycle -> cycle -> cycle list\n\nval to_int32 : cycle -> int32\n\nval of_int32_exn : int32 -> cycle\n\nval of_string_exn : string -> cycle\n\nmodule Map : Map.S with type key = cycle\n\nmodule Index : Storage_description.INDEX with type t = cycle\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t = int32\n\ntype cycle = t\n\nlet encoding = Data_encoding.int32\n\nlet rpc_arg = RPC_arg.like RPC_arg.uint31 ~descr:\"A cycle integer\" \"block_cycle\"\n\nlet pp ppf cycle = Format.fprintf ppf \"%ld\" cycle\n\ninclude (Compare.Int32 : Compare.S with type t := t)\n\nmodule Map = Map.Make (Compare.Int32)\n\nlet root = 0l\n\nlet succ = Int32.succ\n\nlet pred = function 0l -> None | i -> Some (Int32.pred i)\n\nlet add c i =\n assert (Compare.Int.(i >= 0)) ;\n Int32.add c (Int32.of_int i)\n\nlet sub c i =\n assert (Compare.Int.(i >= 0)) ;\n let r = Int32.sub c (Int32.of_int i) in\n if Compare.Int32.(r < 0l) then None else Some r\n\nlet diff = Int32.sub\n\nlet to_int32 i = i\n\nlet of_int32_exn l =\n if Compare.Int32.(l >= 0l) then l else invalid_arg \"Cycle_repr.of_int32_exn\"\n\nlet of_string_exn s =\n let int32_opt = Int32.of_string_opt s in\n match int32_opt with\n | None -> invalid_arg \"Cycle_repr.of_string_exn\"\n | Some int32 -> of_int32_exn int32\n\nlet ( ---> ) = Misc.( ---> )\n\nmodule Index = struct\n type t = cycle\n\n let path_length = 1\n\n let to_path c l = Int32.to_string (to_int32 c) :: l\n\n let of_path = function [s] -> Int32.of_string_opt s | _ -> None\n\n let rpc_arg = rpc_arg\n\n let encoding = encoding\n\n let compare = compare\nend\n" ;
} ;
{ name = "Level_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module defines the protocol representation of a level. Besides the \"raw\n level\", which is the shell's notion of the level, this representation also\n contains additional information, like the cycle the level belongs to. *)\n\ntype t = private {\n level : Raw_level_repr.t;\n (** The level of the block relative to genesis. This\n is also the Shell's notion of level. *)\n level_position : int32;\n (** The level of the block relative to the block that starts the\n alpha family of protocols. *)\n cycle : Cycle_repr.t;\n (** The current cycle's number. Note that cycles are a protocol-specific\n notion. As a result, the cycle number starts at 0 with the first block of\n the first version of protocol alpha. *)\n cycle_position : int32;\n (** The current level of the block relative to the first block of the current\n cycle. *)\n expected_commitment : bool;\n}\n\ntype level = t\n\ninclude Compare.S with type t := level\n\nval encoding : level Data_encoding.t\n\nval pp : Format.formatter -> level -> unit\n\nval pp_full : Format.formatter -> level -> unit\n\nval diff : level -> level -> int32\n\n(** A cycle era is a chunk of cycles having the same number of levels\n per cycle and the same number of blocks per commitment. *)\ntype cycle_era = {\n first_level : Raw_level_repr.t; (** The first level of a cycle era. *)\n first_cycle : Cycle_repr.t; (** The first cycle of a cycle era. *)\n blocks_per_cycle : int32;\n (** The value of the blocks_per_cycle constant used during the cycle\n era starting with first_level. *)\n blocks_per_commitment : int32;\n (** The value of the blocks_per_commitment constant used during the\n cycle era starting with first_level. *)\n}\n\n(** Stores the cycles eras of the Alpha family of protocols *)\ntype cycle_eras\n\nval cycle_eras_encoding : cycle_eras Data_encoding.t\n\n(** Preconditions on the input list of cycle eras:\n - the list is not empty\n - the first levels and the first cycles are decreasing, meaning that the\n first era in the list is the current era, and the last era in the list\n is the oldest era\n Invariants:\n - the first era therefore contains the same constants as in Constants\n - the first level of an era is the first level of a cycle\n*)\nval create_cycle_eras : cycle_era list -> cycle_eras tzresult\n\n(** Add a new cycle era *)\nval add_cycle_era : cycle_era -> cycle_eras -> cycle_eras tzresult\n\n(** Returns the current era *)\nval current_era : cycle_eras -> cycle_era\n\n(** Returns the first level of the oldest era *)\nval root_level : cycle_eras -> level\n\n(** Returns the annotated level corresponding to a raw level *)\nval level_from_raw : cycle_eras:cycle_eras -> Raw_level_repr.t -> level\n\n(** Returns the annotated level corresponding to a raw level and an\n offset. A positive offset corresponds to a higher level.\n Fails with [Negative_level_and_offset_sum] if the sum of the raw_level and the offset is negative.\n Fails with [Level_not_in_alpha] if the sum of the raw_level and the offset \n is a level before the first level in the Alpha family of protocols. *)\nval level_from_raw_with_offset :\n cycle_eras:cycle_eras -> offset:int32 -> Raw_level_repr.t -> level tzresult\n\n(** Returns the first level of the given cycle. *)\nval first_level_in_cycle_from_eras :\n cycle_eras:cycle_eras -> Cycle_repr.t -> level\n\n(** Returns true if the given level is the last of a cycle. *)\nval last_of_cycle : cycle_eras:cycle_eras -> level -> bool\n\nmodule Internal_for_tests : sig\n val add_level : t -> int -> t\n\n val add_cycles : blocks_per_cycle:int -> t -> int -> t\nend\n\n(**/**)\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t = {\n level : Raw_level_repr.t;\n level_position : int32;\n cycle : Cycle_repr.t;\n cycle_position : int32;\n expected_commitment : bool;\n}\n\ninclude Compare.Make (struct\n type nonrec t = t\n\n let compare {level = l1; _} {level = l2; _} = Raw_level_repr.compare l1 l2\nend)\n\ntype level = t\n\nlet pp ppf {level; _} = Raw_level_repr.pp ppf level\n\nlet pp_full ppf l =\n Format.fprintf\n ppf\n \"%a.%ld (cycle %a.%ld)\"\n Raw_level_repr.pp\n l.level\n l.level_position\n Cycle_repr.pp\n l.cycle\n l.cycle_position\n\nlet encoding =\n let open Data_encoding in\n conv\n (fun {level; level_position; cycle; cycle_position; expected_commitment} ->\n (level, level_position, cycle, cycle_position, expected_commitment))\n (fun (level, level_position, cycle, cycle_position, expected_commitment) ->\n {level; level_position; cycle; cycle_position; expected_commitment})\n (obj5\n (req\n \"level\"\n ~description:\n \"The level of the block relative to genesis. This is also the \\\n Shell's notion of level.\"\n Raw_level_repr.encoding)\n (req\n \"level_position\"\n ~description:\n \"The level of the block relative to the successor of the genesis \\\n block. More precisely, it is the position of the block relative \\\n to the block that starts the \\\"Alpha family\\\" of protocols, which \\\n includes all protocols except Genesis (that is, from 001 \\\n onwards).\"\n int32)\n (req\n \"cycle\"\n ~description:\n \"The current cycle's number. Note that cycles are a \\\n protocol-specific notion. As a result, the cycle number starts at \\\n 0 with the first block of the Alpha family of protocols.\"\n Cycle_repr.encoding)\n (req\n \"cycle_position\"\n ~description:\n \"The current level of the block relative to the first block of the \\\n current cycle.\"\n int32)\n (req\n \"expected_commitment\"\n ~description:\n \"Tells whether the baker of this block has to commit a seed nonce \\\n hash.\"\n bool))\n\nlet diff {level = l1; _} {level = l2; _} =\n Int32.sub (Raw_level_repr.to_int32 l1) (Raw_level_repr.to_int32 l2)\n\ntype cycle_era = {\n first_level : Raw_level_repr.t;\n first_cycle : Cycle_repr.t;\n blocks_per_cycle : int32;\n blocks_per_commitment : int32;\n}\n\ntype cycle_eras = cycle_era list\n\ntype error += Invalid_cycle_eras\n\nlet () =\n register_error_kind\n `Temporary\n ~id:\"level_repr.invalid_cycle_eras\"\n ~title:\"Invalid cycle eras\"\n ~description:\n \"The cycles eras are not valid: empty list or non-decreasing first \\\n levels or first cycles.\"\n ~pp:(fun ppf () ->\n Format.fprintf\n ppf\n \"The cycles eras are not valid: empty list or non-decreasing first \\\n levels or first cycles.\")\n Data_encoding.empty\n (function Invalid_cycle_eras -> Some () | _ -> None)\n (fun () -> Invalid_cycle_eras)\n\nlet create_cycle_eras cycle_eras =\n match cycle_eras with\n | [] -> error Invalid_cycle_eras\n | newest_era :: older_eras ->\n let rec aux {first_level; first_cycle; _} older_eras =\n match older_eras with\n | ({\n first_level = first_level_of_previous_era;\n first_cycle = first_cycle_of_previous_era;\n _;\n } as previous_era)\n :: even_older_eras ->\n if\n Raw_level_repr.(first_level > first_level_of_previous_era)\n && Cycle_repr.(first_cycle > first_cycle_of_previous_era)\n then aux previous_era even_older_eras\n else error Invalid_cycle_eras\n | [] -> ok ()\n in\n aux newest_era older_eras >>? fun () -> ok cycle_eras\n\nlet add_cycle_era new_era cycle_eras = create_cycle_eras (new_era :: cycle_eras)\n\nlet cycle_era_encoding =\n let open Data_encoding in\n conv\n (fun {first_level; first_cycle; blocks_per_cycle; blocks_per_commitment} ->\n (first_level, first_cycle, blocks_per_cycle, blocks_per_commitment))\n (fun (first_level, first_cycle, blocks_per_cycle, blocks_per_commitment) ->\n {first_level; first_cycle; blocks_per_cycle; blocks_per_commitment})\n (obj4\n (req\n \"first_level\"\n ~description:\"The first level of a new cycle era.\"\n Raw_level_repr.encoding)\n (req\n \"first_cycle\"\n ~description:\"The first cycle of a new cycle era.\"\n Cycle_repr.encoding)\n (req\n \"blocks_per_cycle\"\n ~description:\n \"The value of the blocks_per_cycle constant used during the cycle \\\n era starting with first_level.\"\n int32)\n (req\n \"blocks_per_commitment\"\n ~description:\n \"The value of the blocks_per_commitment constant used during the \\\n cycle era starting with first_level.\"\n int32))\n\nlet cycle_eras_encoding =\n Data_encoding.conv_with_guard\n (fun eras -> eras)\n (fun eras ->\n match create_cycle_eras eras with\n | Ok eras -> Ok eras\n | Error _ -> Error \"Invalid cycle eras\")\n (Data_encoding.list cycle_era_encoding)\n\nlet current_era = function [] -> assert false | cycle_era :: _ -> cycle_era\n\nlet root_level cycle_eras =\n let first_era = List.last_opt cycle_eras in\n let first_era =\n match first_era with\n | Some first_era -> first_era\n | None ->\n (* {!create_cycle_eras} fails if the list is empty.\n {!cycle_eras_encoding} uses {!create_cycle_eras} and so fails on empty\n lists too. *)\n assert false\n in\n {\n level = first_era.first_level;\n level_position = 0l;\n cycle = Cycle_repr.root;\n cycle_position = 0l;\n expected_commitment = false;\n }\n\n(* This function returns the cycle era to which [level] belongs. *)\nlet era_of_level ~cycle_eras level =\n let rec aux = function\n | ({first_level; _} as era) :: previous_eras ->\n if Raw_level_repr.(level >= first_level) then era else aux previous_eras\n | [] -> assert false\n in\n aux cycle_eras\n\n(* This function returns the cycle era to which [cycle] belongs. *)\nlet era_of_cycle ~cycle_eras cycle =\n let rec aux = function\n | ({first_cycle; _} as era) :: previous_eras ->\n if Cycle_repr.(cycle >= first_cycle) then era else aux previous_eras\n | [] -> assert false\n in\n aux cycle_eras\n\n(* precondition: [level] belongs to [era] *)\nlet level_from_raw_with_era era ~first_level_in_alpha_family level =\n let {first_level; first_cycle; blocks_per_cycle; blocks_per_commitment} =\n era\n in\n let level_position_in_era = Raw_level_repr.diff level first_level in\n assert (Compare.Int32.(level_position_in_era >= 0l)) ;\n let cycles_since_era_start =\n Int32.div level_position_in_era blocks_per_cycle\n in\n let cycle =\n Cycle_repr.add first_cycle (Int32.to_int cycles_since_era_start)\n in\n let cycle_position = Int32.rem level_position_in_era blocks_per_cycle in\n let level_position = Raw_level_repr.diff level first_level_in_alpha_family in\n let expected_commitment =\n Compare.Int32.(\n Int32.rem cycle_position blocks_per_commitment\n = Int32.pred blocks_per_commitment)\n in\n {level; level_position; cycle; cycle_position; expected_commitment}\n\nlet level_from_raw_aux_exn ~cycle_eras level =\n let first_level_in_alpha_family =\n match List.rev cycle_eras with\n | [] -> assert false\n | {first_level; _} :: _ -> first_level\n in\n let era = era_of_level ~cycle_eras level in\n level_from_raw_with_era era ~first_level_in_alpha_family level\n\nlet level_from_raw ~cycle_eras l = level_from_raw_aux_exn ~cycle_eras l\n\ntype error += Level_not_in_alpha of Raw_level_repr.t\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"level_not_in_alpha\"\n ~title:\"Level not in Alpha family\"\n ~description:\"Level not in Alpha family\"\n ~pp:(fun ppf level ->\n Format.fprintf\n ppf\n \"Level %a is not in the Alpha family of protocols.\"\n Raw_level_repr.pp\n level)\n Data_encoding.(obj1 (req \"level\" Raw_level_repr.encoding))\n (function Level_not_in_alpha level -> Some level | _ -> None)\n (fun level -> Level_not_in_alpha level)\n\nlet level_from_raw_aux ~cycle_eras level =\n let first_level_in_alpha_family =\n match List.rev cycle_eras with\n | [] -> assert false\n | {first_level; _} :: _ -> first_level\n in\n error_when\n Raw_level_repr.(level < first_level_in_alpha_family)\n (Level_not_in_alpha level)\n >|? fun () ->\n let era = era_of_level ~cycle_eras level in\n level_from_raw_with_era era ~first_level_in_alpha_family level\n\ntype error += Negative_level_and_offset_sum of int32 * int32\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"negative_level_and_offset_sum\"\n ~title:\"Negative sum of level and offset\"\n ~description:\"Negative sum of level and offset\"\n ~pp:(fun ppf (level, offset) ->\n Format.fprintf\n ppf\n \"Sum of level (%ld) and offset (%ld) is negative.\"\n level\n offset)\n Data_encoding.(obj2 (req \"level\" int32) (req \"offset\" int32))\n (function\n | Negative_level_and_offset_sum (level, offset) -> Some (level, offset)\n | _ -> None)\n (fun (level, offset) -> Negative_level_and_offset_sum (level, offset))\n\nlet level_from_raw_with_offset ~cycle_eras ~offset raw_level =\n let res = Raw_level_repr.(of_int32 (Int32.add (to_int32 raw_level) offset)) in\n match res with\n | Ok level -> level_from_raw_aux ~cycle_eras level\n | Error _ ->\n error\n (Negative_level_and_offset_sum\n (Raw_level_repr.to_int32 raw_level, offset))\n\nlet first_level_in_cycle_from_eras ~cycle_eras cycle =\n let first_level_in_alpha_family =\n match List.rev cycle_eras with\n | [] -> assert false\n | {first_level; _} :: _ -> first_level\n in\n let era = era_of_cycle ~cycle_eras cycle in\n let cycle_position = Cycle_repr.diff cycle era.first_cycle in\n let offset = Int32.mul era.blocks_per_cycle cycle_position in\n let first_level_in_cycle =\n Raw_level_repr.(of_int32_exn (Int32.add (to_int32 era.first_level) offset))\n in\n level_from_raw_with_era era ~first_level_in_alpha_family first_level_in_cycle\n\nlet last_of_cycle ~cycle_eras level =\n let era = era_of_level ~cycle_eras level.level in\n Compare.Int32.(Int32.succ level.cycle_position = era.blocks_per_cycle)\n\nmodule Internal_for_tests = struct\n let add_level level n =\n let raw_level = level.level in\n let new_raw_level = Raw_level_repr.add raw_level n in\n {level with level = new_raw_level}\n\n let add_cycles ~blocks_per_cycle level n =\n {\n level with\n cycle = Cycle_repr.add level.cycle n;\n level = Raw_level_repr.add level.level (n * blocks_per_cycle);\n level_position =\n Int32.add level.level_position (Int32.of_int (n * blocks_per_cycle));\n }\nend\n" ;
} ;
{ name = "Script_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Defines a Michelson expression representation as a Micheline node with\n canonical ([int]) location and [Michelson_v1_primitives.prim] as content.\n\n Types [expr] and [node] both define representation of Michelson\n expressions and are indeed the same type internally, although this is not\n visible outside Micheline due to interface abstraction. *)\n\n(** Locations are used by Micheline mostly for error-reporting and pretty-\n printing expressions. [canonical_location] is simply an [int]. *)\ntype location = Micheline.canonical_location\n\n(** Annotations attached to Michelson expressions. *)\ntype annot = Micheline.annot\n\n(** Represents a Michelson expression as canonical Micheline. *)\ntype expr = Michelson_v1_primitives.prim Micheline.canonical\n\ntype error += Lazy_script_decode (* `Permanent *)\n\n(** A record containing either an underlying serialized representation of an\n expression or a deserialized one, or both. If either is absent, it will be\n computed on-demand. *)\ntype lazy_expr = expr Data_encoding.lazy_t\n\ntype 'location michelson_node =\n ('location, Michelson_v1_primitives.prim) Micheline.node\n\n(** Same as [expr], but used in different contexts, as required by Micheline's\n abstract interface. *)\ntype node = location michelson_node\n\nval location_encoding : location Data_encoding.t\n\nval expr_encoding : expr Data_encoding.t\n\nval lazy_expr_encoding : lazy_expr Data_encoding.t\n\nval lazy_expr : expr -> lazy_expr\n\n(** Type [t] joins the contract's code and storage in a single record. *)\ntype t = {code : lazy_expr; storage : lazy_expr}\n\nval encoding : t Data_encoding.encoding\n\n(* Basic gas costs of operations related to processing Michelson: *)\n\nval deserialization_cost_estimated_from_bytes : int -> Gas_limit_repr.cost\n\nval deserialized_cost : expr -> Gas_limit_repr.cost\n\nval bytes_node_cost : bytes -> Gas_limit_repr.cost\n\n(** Returns (a lower bound on) the cost to deserialize a\n {!lazy_expr}. If the expression has already been deserialized\n (i.e. the lazy expression contains the deserialized value or both\n the bytes representation and the deserialized value) then the cost\n is {b free}. *)\nval force_decode_cost : lazy_expr -> Gas_limit_repr.cost\n\n(** Like {!force_decode_cost}, excepted that the returned cost does\n not depend on the internal state of the lazy_expr. This means that\n the cost is never free (excepted for zero bytes expressions). *)\nval stable_force_decode_cost : lazy_expr -> Gas_limit_repr.cost\n\nval force_decode : lazy_expr -> expr tzresult\n\n(** Returns the cost to serialize a {!lazy_expr}. If the expression\n has already been deserialized (i.e. le lazy expression contains the\n bytes representation or both the bytes representation and the\n deserialized value) then the cost is {b free}. *)\nval force_bytes_cost : lazy_expr -> Gas_limit_repr.cost\n\nval force_bytes : lazy_expr -> bytes tzresult\n\nval unit : expr\n\nval unit_parameter : lazy_expr\n\nval is_unit : expr -> bool\n\nval is_unit_parameter : lazy_expr -> bool\n\nval strip_annotations : node -> node\n\nval strip_locations_cost : _ michelson_node -> Gas_limit_repr.cost\n\nval strip_annotations_cost : node -> Gas_limit_repr.cost\n\n(** Computes the cost of serializing a given term. *)\nval micheline_serialization_cost : expr -> Gas_limit_repr.cost\n\nmodule Micheline_size : sig\n type t = {\n nodes : Saturation_repr.may_saturate Saturation_repr.t;\n string_bytes : Saturation_repr.may_saturate Saturation_repr.t;\n z_bytes : Saturation_repr.may_saturate Saturation_repr.t;\n }\n\n val of_node : node -> t\nend\n\n(** [micheline_nodes root] returns the number of internal nodes in the\n micheline expression held from [root]. *)\nval micheline_nodes : node -> int\n\n(** [fold node i f] traverses [node] applying [f] on an\n accumulator initialized by [i]. *)\nval fold :\n ('loc, 'prim) Micheline.node ->\n 'acc ->\n ('acc -> ('loc, 'prim) Micheline.node -> 'acc) ->\n 'acc\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype location = Micheline.canonical_location\n\nlet location_encoding = Micheline.canonical_location_encoding\n\ntype annot = Micheline.annot\n\ntype expr = Michelson_v1_primitives.prim Micheline.canonical\n\ntype lazy_expr = expr Data_encoding.lazy_t\n\ntype 'location michelson_node =\n ('location, Michelson_v1_primitives.prim) Micheline.node\n\ntype node = location michelson_node\n\nlet expr_encoding =\n Micheline.canonical_encoding\n ~variant:\"michelson_v1\"\n Michelson_v1_primitives.prim_encoding\n\ntype error += Lazy_script_decode (* `Permanent *)\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"invalid_binary_format\"\n ~title:\"Invalid binary format\"\n ~description:\n \"Could not deserialize some piece of data from its binary representation\"\n ~pp:(fun fmt () ->\n Format.fprintf\n fmt\n \"Could not deserialize some piece of data from its binary \\\n representation\")\n Data_encoding.empty\n (function Lazy_script_decode -> Some () | _ -> None)\n (fun () -> Lazy_script_decode)\n\nlet lazy_expr_encoding = Data_encoding.lazy_encoding expr_encoding\n\nlet lazy_expr expr = Data_encoding.make_lazy expr_encoding expr\n\ntype t = {code : lazy_expr; storage : lazy_expr}\n\nlet encoding =\n let open Data_encoding in\n def \"scripted.contracts\"\n @@ conv\n (fun {code; storage} -> (code, storage))\n (fun (code, storage) -> {code; storage})\n (obj2 (req \"code\" lazy_expr_encoding) (req \"storage\" lazy_expr_encoding))\n\nmodule S = Saturation_repr\n\nmodule Micheline_size = struct\n type t = {\n nodes : S.may_saturate S.t;\n string_bytes : S.may_saturate S.t;\n z_bytes : S.may_saturate S.t;\n }\n\n let make ~nodes ~string_bytes ~z_bytes = {nodes; string_bytes; z_bytes}\n\n let zero = {nodes = S.zero; string_bytes = S.zero; z_bytes = S.zero}\n\n let add_int acc n =\n let numbits = Z.numbits n in\n let z_bytes =\n S.safe_int ((numbits + 7) / 8)\n (* Compute the number of bytes in a Z.t *)\n in\n {\n nodes = S.succ acc.nodes;\n string_bytes = acc.string_bytes;\n z_bytes = S.add acc.z_bytes z_bytes;\n }\n\n let add_string acc n =\n let string_bytes = S.safe_int (String.length n) in\n {\n nodes = S.succ acc.nodes;\n string_bytes = S.add acc.string_bytes string_bytes;\n z_bytes = acc.z_bytes;\n }\n\n let add_bytes acc n =\n let string_bytes = S.safe_int (Bytes.length n) in\n {\n nodes = S.succ acc.nodes;\n string_bytes = S.add acc.string_bytes string_bytes;\n z_bytes = acc.z_bytes;\n }\n\n let add_node s = {s with nodes = S.succ s.nodes}\n\n (* We model annotations as Seqs of Strings *)\n let of_annots acc annots =\n List.fold_left (fun acc s -> add_string acc s) acc annots\n\n let rec of_nodes acc nodes more_nodes =\n let open Micheline in\n match nodes with\n | [] -> (\n match more_nodes with\n | [] -> acc\n | nodes :: more_nodes ->\n (of_nodes [@ocaml.tailcall]) acc nodes more_nodes)\n | Int (_, n) :: nodes ->\n let acc = add_int acc n in\n (of_nodes [@ocaml.tailcall]) acc nodes more_nodes\n | String (_, s) :: nodes ->\n let acc = add_string acc s in\n (of_nodes [@ocaml.tailcall]) acc nodes more_nodes\n | Bytes (_, s) :: nodes ->\n let acc = add_bytes acc s in\n (of_nodes [@ocaml.tailcall]) acc nodes more_nodes\n | Prim (_, _, args, annots) :: nodes ->\n let acc = add_node acc in\n let acc = of_annots acc annots in\n (of_nodes [@ocaml.tailcall]) acc args (nodes :: more_nodes)\n | Seq (_, args) :: nodes ->\n let acc = add_node acc in\n (of_nodes [@ocaml.tailcall]) acc args (nodes :: more_nodes)\n\n let of_node node = of_nodes zero [node] []\n\n let dot_product s1 s2 =\n S.add\n (S.mul s1.nodes s2.nodes)\n (S.add\n (S.mul s1.string_bytes s2.string_bytes)\n (S.mul s1.z_bytes s2.z_bytes))\nend\n\n(* Costs pertaining to deserialization of Micheline values (bytes to Micheline).\n The costs are given in atomic steps (see [Gas_limit_repr]). *)\nmodule Micheline_decoding = struct\n (* Cost vector allowing to compute decoding costs as a function of the\n size of the Micheline term *)\n let micheline_size_dependent_cost =\n let traversal_cost = S.safe_int 60 in\n let string_per_byte_cost = S.safe_int 10 in\n let z_per_byte_cost = S.safe_int 10 in\n Micheline_size.make\n ~nodes:traversal_cost\n ~string_bytes:string_per_byte_cost\n ~z_bytes:z_per_byte_cost\n\n let bytes_dependent_cost = S.safe_int 20\nend\n\n(* Costs pertaining to serialization of Micheline values (Micheline to bytes)\n The costs are given in atomic steps (see [Gas_limit_repr]). *)\nmodule Micheline_encoding = struct\n (* Cost vector allowing to compute encoding cost as a function of the\n size of the Micheline term *)\n let micheline_size_dependent_cost =\n let traversal_cost = S.safe_int 100 in\n let string_per_byte_cost = S.safe_int 10 in\n let z_per_byte_cost = S.safe_int 25 in\n Micheline_size.make\n ~nodes:traversal_cost\n ~string_bytes:string_per_byte_cost\n ~z_bytes:z_per_byte_cost\n\n let bytes_dependent_cost = S.safe_int 33\nend\n\nlet expr_size expr = Micheline_size.of_node (Micheline.root expr)\n\n(* Compute the cost of serializing a term of given [size]. *)\nlet serialization_cost size =\n Gas_limit_repr.atomic_step_cost\n @@ Micheline_size.dot_product\n size\n Micheline_encoding.micheline_size_dependent_cost\n\n(* Compute the cost of serializing a given term. *)\nlet micheline_serialization_cost v = serialization_cost (expr_size v)\n\n(* Compute the cost of deserializing a term of given [size]. *)\nlet deserialization_cost size =\n Gas_limit_repr.atomic_step_cost\n @@ Micheline_size.dot_product\n size\n Micheline_decoding.micheline_size_dependent_cost\n\n(* Estimate the cost of deserializing a term encoded in [bytes_len] bytes. *)\nlet deserialization_cost_estimated_from_bytes bytes_len =\n Gas_limit_repr.atomic_step_cost\n @@ S.mul Micheline_decoding.bytes_dependent_cost (S.safe_int bytes_len)\n\n(* Estimate the cost of serializing a term from its encoded form,\n having [bytes_len] bytes. *)\nlet serialization_cost_estimated_from_bytes bytes_len =\n Gas_limit_repr.atomic_step_cost\n @@ S.mul Micheline_encoding.bytes_dependent_cost (S.safe_int bytes_len)\n\n(* Cost of running [strip_locations] on a term with [size] nodes.\n Note that [strip_locations] will reallocate a fresh Micheline tree.\n This only depends on the total number of nodes (not the size of\n the leaves). *)\nlet cost_micheline_strip_locations size =\n Gas_limit_repr.atomic_step_cost @@ S.mul (S.safe_int size) (S.safe_int 51)\n\n(* TODO: https://gitlab.com/tezos/tezos/-/issues/2049\n Plugin benchmarked gas.\n Replace this definition, copied from [cost_michelines_strip_locations].\n*)\n(* Cost of running [strip_annotations] on a term with [size] nodes.\n Note that [strip_annotations] will reallocate a fresh Micheline tree.\n This only depends on the total number of nodes (not the size of\n the leaves). *)\nlet cost_micheline_strip_annotations size =\n Gas_limit_repr.atomic_step_cost @@ S.mul (S.safe_int size) (S.safe_int 51)\n\n(* This is currently used to estimate the cost of serializing an operation. *)\nlet bytes_node_cost s = serialization_cost_estimated_from_bytes (Bytes.length s)\n\nlet deserialized_cost expr =\n Gas_limit_repr.atomic_step_cost @@ deserialization_cost (expr_size expr)\n\nlet force_decode_cost lexpr =\n Data_encoding.apply_lazy\n ~fun_value:(fun _ -> Gas_limit_repr.free)\n ~fun_bytes:(fun b ->\n deserialization_cost_estimated_from_bytes (Bytes.length b))\n ~fun_combine:(fun _ _ -> Gas_limit_repr.free)\n lexpr\n\nlet stable_force_decode_cost lexpr =\n let has_bytes =\n Data_encoding.apply_lazy\n ~fun_value:(fun v -> `Only_value v)\n ~fun_bytes:(fun b -> `Has_bytes b)\n ~fun_combine:(fun _v b ->\n (* When the lazy_expr contains both a deserialized version\n and a serialized one, we compute the cost from the\n serialized version because its is cheaper to do. *)\n b)\n lexpr\n in\n match has_bytes with\n | `Has_bytes b -> deserialization_cost_estimated_from_bytes (Bytes.length b)\n | `Only_value v ->\n (* This code path should not be reached in theory because values that are\n decoded should have been encoded before.\n Here we use Data_encoding.Binary.length, which yields the same results\n as serializing the value and taking the size, without the need to\n encode (in particular, less allocations).\n *)\n deserialization_cost_estimated_from_bytes\n (Data_encoding.Binary.length expr_encoding v)\n\nlet force_decode lexpr =\n match Data_encoding.force_decode lexpr with\n | Some v -> ok v\n | None -> error Lazy_script_decode\n\nlet force_bytes_cost expr =\n (* Estimating the cost directly from the bytes would be cheaper, but\n using [serialization_cost] is more accurate. *)\n Data_encoding.apply_lazy\n ~fun_value:(fun v -> Some v)\n ~fun_bytes:(fun _ -> None)\n ~fun_combine:(fun _ _ -> None)\n expr\n |> Option.fold ~none:Gas_limit_repr.free ~some:micheline_serialization_cost\n\nlet force_bytes expr =\n Error_monad.catch_f\n (fun () -> Data_encoding.force_bytes expr)\n (fun _ -> Lazy_script_decode)\n\nlet unit =\n Micheline.strip_locations (Prim (0, Michelson_v1_primitives.D_Unit, [], []))\n\nlet unit_parameter = lazy_expr unit\n\nlet is_unit v =\n match Micheline.root v with\n | Prim (_, Michelson_v1_primitives.D_Unit, [], []) -> true\n | _ -> false\n\nlet is_unit_parameter =\n let unit_bytes = Data_encoding.force_bytes unit_parameter in\n Data_encoding.apply_lazy\n ~fun_value:is_unit\n ~fun_bytes:(fun b -> Compare.Bytes.equal b unit_bytes)\n ~fun_combine:(fun res _ -> res)\n\nlet rec strip_annotations node =\n let open Micheline in\n match node with\n | (Int (_, _) | String (_, _) | Bytes (_, _)) as leaf -> leaf\n | Prim (loc, name, args, _) ->\n Prim (loc, name, List.map strip_annotations args, [])\n | Seq (loc, args) -> Seq (loc, List.map strip_annotations args)\n\nlet rec micheline_fold_aux node f acc k =\n match node with\n | Micheline.Int (_, _) -> k (f acc node)\n | Micheline.String (_, _) -> k (f acc node)\n | Micheline.Bytes (_, _) -> k (f acc node)\n | Micheline.Prim (_, _, subterms, _) ->\n micheline_fold_nodes subterms f (f acc node) k\n | Micheline.Seq (_, subterms) ->\n micheline_fold_nodes subterms f (f acc node) k\n\nand micheline_fold_nodes subterms f acc k =\n match subterms with\n | [] -> k acc\n | node :: nodes ->\n micheline_fold_nodes nodes f acc @@ fun acc ->\n micheline_fold_aux node f acc k\n\nlet fold node init f = micheline_fold_aux node f init (fun x -> x)\n\nlet micheline_nodes node = fold node 0 @@ fun n _ -> n + 1\n\nlet strip_locations_cost node =\n let nodes = micheline_nodes node in\n cost_micheline_strip_locations nodes\n\nlet strip_annotations_cost node =\n let nodes = micheline_nodes node in\n cost_micheline_strip_annotations nodes\n" ;
} ;
{ name = "Cache_memory_helpers" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule type SNodes = sig\n type t = private int\n\n val zero : t\n\n val one : t [@@ocaml.warning \"-32\"]\n\n val succ : t -> t\n\n val add : t -> t -> t\n\n val to_int : t -> int\nend\n\n(** The [Nodes] module is used to count the number of computation steps\n performed when evaluating the size of the in-memory graph corresponding\n to an OCaml value.\n\n In first approximation, the value of type [Nodes.t] threaded through\n {!expr_size} below and through the module {!Script_typed_ir_size}\n is meant to match the number of recursive calls in the [traverse]\n functions of {!Script_typed_ir} and in that of {!node_size}.\n\n The assumption is that there's a bounded amount of work performed between\n two such recursive calls, hence that the total work is bounded above\n by something proportional to the [Nodes.t] accumulator.\n\n Computations on values of type [Nodes.t] do not overflow, as they\n are bounded above by the number of nodes traversed when computing\n an OCaml value.\n *)\nmodule Nodes : SNodes = struct\n type t = int\n\n let zero = 0\n\n let one = 1\n\n let succ x = x + 1\n\n let add x y = x + y\n\n let to_int x = x\nend\n\n(** {2 Helpers to deal with computing the in-memory size of values} *)\n\ntype sint = Saturation_repr.may_saturate Saturation_repr.t\n\ntype nodes_and_size = Nodes.t * sint\n\nlet ( !! ) = Saturation_repr.safe_int\n\nlet ( +! ) = Saturation_repr.add\n\nlet ( +? ) s x = Saturation_repr.add s !!x\n\nlet ( *? ) s x = Saturation_repr.mul s !!x\n\nlet ( /? ) s x = Saturation_repr.ediv s !!x\n\nlet ( ++ ) (n1, s1) (n2, s2) = (Nodes.add n1 n2, s1 +! s2)\n\nlet zero = (Nodes.zero, !!0)\n\nlet word_size = !!8\n\nlet header_size = word_size\n\nlet int32_size = header_size +! word_size\n\nlet int64_size = header_size +! (word_size *? 2)\n\nlet h1w = header_size +! word_size\n\nlet h2w = header_size +! (word_size *? 2)\n\nlet h3w = header_size +! (word_size *? 3)\n\nlet h4w = header_size +! (word_size *? 4)\n\nlet h5w = header_size +! (word_size *? 5)\n\nlet hh3w = (word_size *? 3) +! (header_size *? 2)\n\nlet hh6w = (word_size *? 6) +! (header_size *? 2)\n\nlet hh8w = (word_size *? 8) +! (header_size *? 2)\n\nlet z_size z =\n let numbits = Z.numbits z in\n (*\n Z does not seem to have a canonical representation of numbers.\n Hence, even though we observed that 24 works in many cases we\n sometimes meet numbers with a larger size, hence we use 32 instead\n of 24 in the following formula.\n *)\n if Compare.Int.(numbits <= 62) then !!0 else (word_size *? Z.size z) +? 32\n\nlet string_size_gen len = header_size +? (len + (8 - (len mod 8)))\n\nlet bytes_size b = string_size_gen (Bytes.length b)\n\nlet string_size s = string_size_gen (String.length s)\n\nlet blake2b_hash_size = h1w +! string_size_gen 20\n\nlet public_key_hash_in_memory_size = h1w +! blake2b_hash_size\n\nlet ret_adding (nodes, size) added = (nodes, size +! added)\n\nlet ret_succ_adding (nodes, size) added = (Nodes.succ nodes, size +! added)\n\nlet ret_succ (nodes, size) = (Nodes.succ nodes, size)\n\nlet option_size some x =\n let some x = h1w +! some x in\n Option.fold ~none:!!0 ~some x\n\nlet option_size_vec some x =\n let some x = ret_adding (some x) h1w in\n Option.fold ~none:zero ~some x\n\nlet list_cell_size elt_size = header_size +! word_size +! word_size +! elt_size\n [@@ocaml.inline always]\n\nlet list_fold_size elt_size list =\n List.fold_left\n (fun accu elt -> ret_succ_adding (accu ++ elt_size elt) h2w)\n zero\n list\n\nlet boxed_tup2 x y = header_size +! word_size +! word_size +! x +! y\n [@@ocaml.inline always]\n\nlet node_size =\n let open Micheline in\n (* An OCaml list item occupies 3 words of memory: one for the (::)\n constructor, one for the item itself (head) and one for the\n remainder of the list (tail). *)\n let list_size sns = word_size *? (List.length sns * 3) in\n let annotation_size a =\n List.fold_left\n (fun accu s -> ret_succ_adding accu (h2w +! string_size s))\n zero\n a\n in\n let internal_node_size = function\n | Int (_, z) -> (Nodes.one, h2w +! z_size z)\n | String (_, s) -> (Nodes.one, h2w +! string_size s)\n | Bytes (_, s) -> (Nodes.one, h2w +! bytes_size s)\n | Prim (_, _, args, a) ->\n ret_succ_adding (annotation_size a) (list_size args +! h4w)\n | Seq (_, terms) -> (Nodes.one, list_size terms +! h2w)\n in\n fun node ->\n Script_repr.fold node zero @@ fun accu node ->\n accu ++ internal_node_size node\n\nlet expr_size expr = node_size (Micheline.root expr)\n" ;
} ;
{ name = "Seed_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Tezos Protocol Implementation - Random number generation\n\n This is not expected to be a good cryptographic random number\n generator. In particular this is supposed to be used in situations\n where the seed is a globally known information.\n\n The only expected property is: It should be difficult to find a\n seed such that the generated sequence is a given one. *)\n\n(** {2 Random Generation} *)\n\n(** The state of the random number generator *)\ntype t\n\n(** A random seed, to derive random sequences from *)\ntype seed\n\n(** A random sequence, to derive random values from *)\ntype sequence\n\n(** A VDF discriminant and challenge *)\ntype vdf_setup = Vdf.discriminant * Vdf.challenge\n\n(** A VDF result, to derive a seed from *)\ntype vdf_solution = Vdf.result * Vdf.proof\n\nval pp_solution : Format.formatter -> vdf_solution -> unit\n\n(** Compare only the first element of two vdf_solution, that are\n of [Vdf.result]. *)\nval compare_vdf_solution : vdf_solution -> vdf_solution -> int\n\nval generate_vdf_setup :\n seed_discriminant:seed -> seed_challenge:seed -> vdf_setup\n\nval verify : vdf_setup -> Int64.t -> vdf_solution -> bool option\n\nval vdf_to_seed : seed -> vdf_solution -> seed\n\n(** [initialize_new state ident] returns a new generator *)\nval initialize_new : seed -> bytes list -> t\n\n(** [sequence state n] prepares the n-th sequence of a state *)\nval sequence : t -> int32 -> sequence\n\n(** Generates the next random value in the sequence *)\nval take : sequence -> bytes * sequence\n\n(** [take_int32 s bound] generates the next random value as a bounded [int32]\n\n @param bound must be a positive integer\n @raise Invalid_argument \"Seed_repr.take_int32\" if [bound] <= 0\n *)\nval take_int32 : sequence -> int32 -> int32 * sequence\n\n(** [take_int64 s bound] generates the next random value as a bounded [int64]\n\n @param bound must be a positive integer\n @raise Invalid_argument \"Seed_repr.take_int64\" if [bound] <= 0\n *)\nval take_int64 : sequence -> int64 -> int64 * sequence\n\n(** {2 Entropy} *)\n\n(** A nonce for adding entropy to the generator *)\ntype nonce\n\n(** Add entropy to the seed generator *)\nval update_seed : seed -> nonce -> seed\n\n(** Use a byte sequence as a nonce *)\nval make_nonce : bytes -> nonce tzresult\n\n(** Compute the hash of a nonce *)\nval hash : nonce -> Nonce_hash.t\n\n(** [check_hash nonce hash] is true if the nonce correspond to the hash *)\nval check_hash : nonce -> Nonce_hash.t -> bool\n\n(** For using nonce hashes as keys in the hierarchical database *)\nval nonce_hash_key_part : Nonce_hash.t -> string list -> string list\n\n(** Returns a new seed by hashing the one passed with a constant. *)\nval deterministic_seed : seed -> seed\n\n(** [initial_seeds n] generates the first [n] seeds for which there are no nonces.\n The first seed is a constant value. The kth seed is the hash of seed (k-1)\n concatenated with a constant. If an [initial_seed] is provided, the\n {i first} seed is created using it as the first one. *)\nval initial_seeds : ?initial_seed:State_hash.t -> int -> seed list\n\n(** {2 Predefined nonce} *)\n\nval initial_nonce_0 : nonce\n\nval initial_nonce_hash_0 : Nonce_hash.t\n\n(** {2 Serializers} *)\n\nval nonce_encoding : nonce Data_encoding.t\n\nval seed_encoding : seed Data_encoding.t\n\nval vdf_setup_encoding : vdf_setup Data_encoding.t\n\nval vdf_solution_encoding : vdf_solution Data_encoding.t\n\ntype seed_status = RANDAO_seed | VDF_seed\n\nval seed_status_encoding : seed_status Data_encoding.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(* Tezos Protocol Implementation - Random number generation *)\n\ntype seed = B of State_hash.t\n\ntype t = T of State_hash.t\n\ntype sequence = S of State_hash.t\n\ntype nonce = bytes\n\ntype vdf_setup = Vdf.discriminant * Vdf.challenge\n\ntype vdf_solution = Vdf.result * Vdf.proof\n\nlet seed_to_bytes x =\n let seed_to_state_hash (B b) = b in\n State_hash.to_bytes (seed_to_state_hash x)\n\nlet vdf_setup_encoding =\n let open Data_encoding in\n let vdf_discriminant_encoding =\n conv_with_guard\n Vdf.discriminant_to_bytes\n (fun b ->\n Option.to_result\n ~none:\"VDF discriminant could not be deserialised\"\n (Vdf.discriminant_of_bytes_opt b))\n (Fixed.(bytes Hex) Vdf.discriminant_size_bytes)\n in\n let vdf_challenge_encoding =\n conv_with_guard\n Vdf.challenge_to_bytes\n (fun b ->\n Option.to_result\n ~none:\"VDF challenge could not be deserialised\"\n (Vdf.challenge_of_bytes_opt b))\n (Fixed.(bytes Hex) Vdf.form_size_bytes)\n in\n tup2 vdf_discriminant_encoding vdf_challenge_encoding\n\nlet vdf_solution_encoding =\n let open Data_encoding in\n let vdf_result_encoding =\n conv_with_guard\n Vdf.result_to_bytes\n (fun b ->\n Option.to_result\n ~none:\"VDF result could not be deserialised\"\n (Vdf.result_of_bytes_opt b))\n (Fixed.(bytes Hex) Vdf.form_size_bytes)\n in\n let vdf_proof_encoding =\n conv_with_guard\n Vdf.proof_to_bytes\n (fun b ->\n Option.to_result\n ~none:\"VDF proof could not be deserialised\"\n (Vdf.proof_of_bytes_opt b))\n (Fixed.(bytes Hex) Vdf.form_size_bytes)\n in\n tup2 vdf_result_encoding vdf_proof_encoding\n\nlet pp_solution ppf solution =\n let result, proof = solution in\n Format.fprintf\n ppf\n \"@[<v 2>VDF result: %a\"\n Hex.pp\n (Hex.of_bytes (Vdf.result_to_bytes result)) ;\n Format.fprintf\n ppf\n \"@,VDF proof: %a\"\n Hex.pp\n (Hex.of_bytes (Vdf.proof_to_bytes proof)) ;\n Format.fprintf ppf \"@]\"\n\nlet nonce_encoding = Data_encoding.Fixed.(bytes Hex) Constants_repr.nonce_length\n\nlet zero_bytes = Bytes.make Nonce_hash.size '\\000'\n\nlet state_hash_encoding =\n let open Data_encoding in\n conv\n State_hash.to_bytes\n State_hash.of_bytes_exn\n (Fixed.(bytes Hex) Nonce_hash.size)\n\nlet seed_encoding =\n let open Data_encoding in\n conv (fun (B b) -> b) (fun b -> B b) state_hash_encoding\n\nlet update_seed (B state) nonce =\n B (State_hash.hash_bytes [State_hash.to_bytes state; nonce])\n\nlet initialize_new (B state) append =\n T (State_hash.hash_bytes (State_hash.to_bytes state :: zero_bytes :: append))\n\nlet xor_higher_bits i b =\n let higher = TzEndian.get_int32 b 0 in\n let r = Int32.logxor higher i in\n let res = Bytes.copy b in\n TzEndian.set_int32 res 0 r ;\n res\n\nlet sequence (T state) n =\n State_hash.to_bytes state |> xor_higher_bits n |> fun b ->\n S (State_hash.hash_bytes [b])\n\nlet take (S state) =\n let b = State_hash.to_bytes state in\n let h = State_hash.hash_bytes [b] in\n (State_hash.to_bytes h, S h)\n\nlet take_int32 s bound =\n if Compare.Int32.(bound <= 0l) then invalid_arg \"Seed_repr.take_int32\"\n (* FIXME *)\n else\n let drop_if_over =\n Int32.sub Int32.max_int (Int32.rem Int32.max_int bound)\n in\n let rec loop s =\n let bytes, s = take s in\n let r = TzEndian.get_int32 bytes 0 in\n (* The absolute value of min_int is min_int. Also, every\n positive integer is represented twice (positive and negative),\n but zero is only represented once. We fix both problems at\n once. *)\n let r = if Compare.Int32.(r = Int32.min_int) then 0l else Int32.abs r in\n if Compare.Int32.(r >= drop_if_over) then loop s\n else\n let v = Int32.rem r bound in\n (v, s)\n in\n loop s\n\nlet take_int64 s bound =\n if Compare.Int64.(bound <= 0L) then invalid_arg \"Seed_repr.take_int64\"\n (* FIXME *)\n else\n let drop_if_over =\n Int64.sub Int64.max_int (Int64.rem Int64.max_int bound)\n in\n\n let rec loop s =\n let bytes, s = take s in\n let r = TzEndian.get_int64 bytes 0 in\n (* The absolute value of min_int is min_int. Also, every\n positive integer is represented twice (positive and negative),\n but zero is only represented once. We fix both problems at\n once. *)\n let r = if Compare.Int64.(r = Int64.min_int) then 0L else Int64.abs r in\n if Compare.Int64.(r >= drop_if_over) then loop s\n else\n let v = Int64.rem r bound in\n (v, s)\n in\n loop s\n\ntype error += Unexpected_nonce_length (* `Permanent *)\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"unexpected_nonce_length\"\n ~title:\"Unexpected nonce length\"\n ~description:\"Nonce length is incorrect.\"\n ~pp:(fun ppf () ->\n Format.fprintf\n ppf\n \"Nonce length is not %i bytes long as it should.\"\n Constants_repr.nonce_length)\n Data_encoding.empty\n (function Unexpected_nonce_length -> Some () | _ -> None)\n (fun () -> Unexpected_nonce_length)\n\nlet make_nonce nonce =\n if Compare.Int.(Bytes.length nonce <> Constants_repr.nonce_length) then\n error Unexpected_nonce_length\n else ok nonce\n\nlet hash nonce = Nonce_hash.hash_bytes [nonce]\n\nlet check_hash nonce hash =\n Compare.Int.(Bytes.length nonce = Constants_repr.nonce_length)\n && Nonce_hash.equal (Nonce_hash.hash_bytes [nonce]) hash\n\nlet nonce_hash_key_part = Nonce_hash.to_path\n\nlet initial_nonce_0 = zero_bytes\n\nlet initial_nonce_hash_0 = hash initial_nonce_0\n\nlet deterministic_seed seed = update_seed seed zero_bytes\n\nlet initial_seeds ?initial_seed n =\n let rec loop acc elt i =\n if Compare.Int.(i = 1) then List.rev (elt :: acc)\n else loop (elt :: acc) (deterministic_seed elt) (i - 1)\n in\n let first_seed =\n match initial_seed with\n | Some initial_seed -> update_seed (B initial_seed) initial_nonce_0\n | None -> B (State_hash.hash_bytes [])\n in\n loop [] first_seed n\n\nlet nonce_discriminant = Bytes.of_string \"Tezos_generating_vdf_discriminant\"\n\nlet nonce_challenge = Bytes.of_string \"Tezos_generating_vdf_challenge\"\n\nlet generate_vdf_setup ~seed_discriminant ~seed_challenge =\n let size = Vdf.discriminant_size_bytes in\n let seed =\n update_seed seed_discriminant nonce_discriminant |> seed_to_bytes\n in\n let discriminant = Vdf.generate_discriminant ~seed size in\n let input = update_seed seed_challenge nonce_challenge |> seed_to_bytes in\n let challenge = Vdf.generate_challenge discriminant input in\n (discriminant, challenge)\n\nlet verify (discriminant, challenge) vdf_difficulty solution =\n (* We return false when getting non group elements as input *)\n let result, proof = solution in\n (* Note: external library call must be wrapped to ensure that\n exceptions are caught. *)\n Option.catch (fun () ->\n Vdf.verify discriminant challenge vdf_difficulty result proof)\n\nlet vdf_to_seed seed_challenge solution =\n let result, _ = solution in\n update_seed seed_challenge (Vdf.result_to_bytes result)\n\ntype seed_status = RANDAO_seed | VDF_seed\n\nlet seed_status_encoding =\n let to_bool = function RANDAO_seed -> false | VDF_seed -> true in\n let of_bool t = if t then VDF_seed else RANDAO_seed in\n Data_encoding.conv to_bool of_bool Data_encoding.bool\n\nlet compare_vdf_solution solution solution' =\n let result, _ = solution in\n let result', _ = solution' in\n Compare.Bytes.compare\n (Vdf.result_to_bytes result)\n (Vdf.result_to_bytes result')\n" ;
} ;
{ name = "Sampler" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n(** Efficient sampling from given finitely supported (nonzero, positive)\n measures using the alias method. Measures need not be normalized on input,\n but sampling proceeds from the normalized probability measure associated\n to the given measure.\n *)\n\n(** [S] is the module type of a module allowing to construct samplers based\n on the alias method. *)\nmodule type S = sig\n (** [mass] is the type in which finite measures take their values\n (see [Mass] module type). *)\n type mass\n\n (** ['a t] is the type of auxilliary data for sampling from\n a given distribution. *)\n type 'a t\n\n (** [create measure] constructs auxilliary data to sample from\n [measure] after normalization. Complexity: O(n).\n\n It is assumed that the measure is positive. [measure] can contain\n zero mass elements: those are removed in a pre-processing step.\n The total mass of the measure should be strictly positive.\n\n @raise Invalid_argument if [measure] contains negative mass elements\n or if it contains only zero mass elements. *)\n val create : ('a * mass) list -> 'a t\n\n (** [sample auxdata rand] creates a sampler from [auxdata] that follows\n the distribution associated to the measure specified when\n creating the [auxdata]. The parameter [rand] is a random sampler\n for the two random values used by the sampling method. The first\n bound is at most the length of the list passed to [create] when\n creating [auxdata]. The second bound is at most the sum of all\n items in the list passed to [create]. *)\n val sample : 'a t -> (int_bound:int -> mass_bound:mass -> int * mass) -> 'a\n\n (** [encoding e] constructs an encoding for ['a t] given an encoding for ['a]. *)\n val encoding : 'a Data_encoding.t -> 'a t Data_encoding.t\nend\n\n(**/**)\n\nmodule Internal_for_tests : sig\n (** [Mass] is the module type describing the measure associated to points.\n\n The current signature reflects the need for efficiency for the arithmetic\n operators. As such, they do not error or add dynamic checks for\n over-/under-flow.\n\n One must make sure that the implementation of its arithmetic operators\n cannot over-/under-flow under the current usage. *)\n module type SMass = sig\n (** [t] is the type describing the measure associated to points. *)\n type t\n\n val encoding : t Data_encoding.t\n\n val zero : t\n\n val of_int : int -> t\n\n val mul : t -> t -> t\n\n val add : t -> t -> t\n\n val sub : t -> t -> t\n\n val ( = ) : t -> t -> bool\n\n val ( <= ) : t -> t -> bool\n\n val ( < ) : t -> t -> bool\n end\n\n (** [Make(Mass)] instantiates a module allowing to creates\n samplers for [Mass]-valued finite measures. *)\n module Make : functor (Mass : SMass) -> S with type mass = Mass.t\nend\n\n(** Sampler based on int64. In the current state of the protocol, this should\n not ever over-/under-flow -- see the thought process in the .ml file.\n\n However, should the total stake increase a lot or the number of delegates get\n close to 10k, this might not be true anymore and this module should be\n revisited. *)\ninclude S with type mass = Int64.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(*\n\n This module implements the alias method for sampling from a given\n distribution. The distribution need not be normalized.\n\n*)\n\nmodule type SMass = sig\n type t\n\n val encoding : t Data_encoding.t\n\n val zero : t\n\n val of_int : int -> t\n\n val mul : t -> t -> t\n\n val add : t -> t -> t\n\n val sub : t -> t -> t\n\n val ( = ) : t -> t -> bool\n\n val ( <= ) : t -> t -> bool\n\n val ( < ) : t -> t -> bool\nend\n\nmodule type S = sig\n type mass\n\n type 'a t\n\n val create : ('a * mass) list -> 'a t\n\n val sample : 'a t -> (int_bound:int -> mass_bound:mass -> int * mass) -> 'a\n\n val encoding : 'a Data_encoding.t -> 'a t Data_encoding.t\nend\n\nmodule Make (Mass : SMass) : S with type mass = Mass.t = struct\n type mass = Mass.t\n\n type 'a t = {\n total : Mass.t;\n support : 'a FallbackArray.t;\n p : Mass.t FallbackArray.t;\n alias : int FallbackArray.t;\n }\n\n let rec init_loop total p alias small large =\n match (small, large) with\n | [], _ -> List.iter (fun (_, i) -> FallbackArray.set p i total) large\n | _, [] ->\n (* This can only happen because of numerical inaccuracies e.g. when using\n [Mass.t = float] *)\n List.iter (fun (_, i) -> FallbackArray.set p i total) small\n | (qi, i) :: small', (qj, j) :: large' ->\n FallbackArray.set p i qi ;\n FallbackArray.set alias i j ;\n let qj' = Mass.sub (Mass.add qi qj) total in\n if Mass.(qj' < total) then\n init_loop total p alias ((qj', j) :: small') large'\n else init_loop total p alias small' ((qj', j) :: large')\n\n let support : fallback:'a -> ('a * Mass.t) list -> 'a FallbackArray.t =\n fun ~fallback measure -> FallbackArray.of_list ~fallback ~proj:fst measure\n\n let check_and_cleanup measure =\n let total, measure =\n List.fold_left\n (fun ((total, m) as acc) ((_, p) as point) ->\n if Mass.(zero < p) then (Mass.add total p, point :: m)\n else if Mass.(p < zero) then invalid_arg \"create\"\n else (* p = zero: drop point *)\n acc)\n (Mass.zero, [])\n measure\n in\n match measure with\n | [] -> invalid_arg \"create\"\n | (fallback, _) :: _ -> (fallback, total, measure)\n\n (* NB: duplicate elements in the support are not merged;\n the algorithm should still function correctly. *)\n let create (measure : ('a * Mass.t) list) =\n let fallback, total, measure = check_and_cleanup measure in\n let length = List.length measure in\n let n = Mass.of_int length in\n let _, small, large =\n List.fold_left\n (fun (i, small, large) (_, p) ->\n let q = Mass.mul p n in\n if Mass.(q < total) then (i + 1, (q, i) :: small, large)\n else (i + 1, small, (q, i) :: large))\n (0, [], [])\n measure\n in\n let support = support ~fallback measure in\n let p = FallbackArray.make length Mass.zero in\n let alias = FallbackArray.make length (-1) in\n init_loop total p alias small large ;\n {total; support; p; alias}\n\n let sample {total; support; p; alias} draw_i_elt =\n let n = FallbackArray.length support in\n let i, elt = draw_i_elt ~int_bound:n ~mass_bound:total in\n let p = FallbackArray.get p i in\n if Mass.(elt < p) then FallbackArray.get support i\n else\n let j = FallbackArray.get alias i in\n assert (Compare.Int.(j >= 0)) ;\n FallbackArray.get support j\n\n (* Note: this could go in the environment maybe? *)\n let array_encoding : 'a Data_encoding.t -> 'a FallbackArray.t Data_encoding.t\n =\n fun venc ->\n let open Data_encoding in\n conv\n (fun array ->\n let length = FallbackArray.length array in\n let fallback = FallbackArray.fallback array in\n let elements =\n List.rev (FallbackArray.fold (fun acc elt -> elt :: acc) array [])\n in\n (length, fallback, elements))\n (fun (length, fallback, elements) ->\n let array = FallbackArray.make length fallback in\n List.iteri (fun i elt -> FallbackArray.set array i elt) elements ;\n array)\n (obj3\n (req \"length\" int31)\n (req \"fallback\" venc)\n (req \"elements\" (list venc)))\n\n let mass_array_encoding = array_encoding Mass.encoding\n\n let int_array_encoding = array_encoding Data_encoding.int31\n\n let encoding enc =\n let open Data_encoding in\n conv\n (fun {total; support; p; alias} -> (total, support, p, alias))\n (fun (total, support, p, alias) -> {total; support; p; alias})\n (obj4\n (req \"total\" Mass.encoding)\n (req \"support\" (array_encoding enc))\n (req \"p\" mass_array_encoding)\n (req \"alias\" int_array_encoding))\nend\n\nmodule Internal_for_tests = struct\n module Make = Make\n\n module type SMass = SMass\nend\n\nmodule Mass : SMass with type t = int64 = struct\n type t = int64\n\n let encoding = Data_encoding.int64\n\n let zero = 0L\n\n let of_int = Int64.of_int\n\n let mul = Int64.mul\n\n let add = Int64.add\n\n let sub = Int64.sub\n\n let ( = ) = Compare.Int64.( = )\n\n let ( <= ) = Compare.Int64.( <= )\n\n let ( < ) = Compare.Int64.( < )\nend\n\n(* This is currently safe to do that since since at this point the values for\n [total] is 8 * 10^8 * 10^6 and the delegates [n] = 400.\n\n Therefore [let q = Mass.mul p n ...] in [create] does not overflow since p <\n total.\n\n Assuming the total active stake does not increase too much, which is the case\n at the current 5% inflation rate, this implementation can thus support around\n 10000 delegates without overflows.\n\n If/when this happens, the implementation should be revisited.\n*)\ninclude Make (Mass)\n" ;
} ;
{ name = "Voting_period_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** The voting period kinds are ordered as follows:\n Proposal -> Exploration -> Cooldown -> Promotion -> Adoption.\n This order is the one used be the function [succ] below.\n *)\ntype kind =\n | Proposal (** protocols can be proposed *)\n | Exploration (** a proposal can be voted *)\n | Cooldown (** a delay before the second vote of the Promotion period. *)\n | Promotion (** activation can be voted *)\n | Adoption (** a delay before activation *)\n\nval kind_encoding : kind Data_encoding.t\n\n(** A voting period can be of several kinds and is uniquely identified by\n the counter 'index'. The 'start_position' represents the relative\n position of the first level of the period with respect to the\n first level of the Alpha family of protocols. *)\ntype voting_period = {index : Int32.t; kind : kind; start_position : Int32.t}\n\ntype t = voting_period\n\n(** Information about a block with respect to the voting period it\n belongs to: the voting period, the position within the voting\n period and the number of remaining blocks till the end of the\n period. The following invariant is satisfied:\n `position + remaining + 1 = blocks_per_voting_period` *)\ntype info = {voting_period : t; position : Int32.t; remaining : Int32.t}\n\nval root : start_position:Int32.t -> t\n\ninclude Compare.S with type t := voting_period\n\nval encoding : t Data_encoding.t\n\nval info_encoding : info Data_encoding.t\n\nval pp : Format.formatter -> t -> unit\n\nval pp_info : Format.formatter -> info -> unit\n\nval pp_kind : Format.formatter -> kind -> unit\n\n(** [raw_reset period ~start_position] increment the index by one and set the\n kind to Proposal which is the period kind that start the voting\n process. [start_position] is the level at wich this voting_period started.\n*)\nval raw_reset : t -> start_position:Int32.t -> t\n\n(** [raw_succ period ~start_position] increment the index by one and set the\n kind to its successor. [start_position] is the level at which this\n voting_period started. *)\nval raw_succ : t -> start_position:Int32.t -> t\n\nval position_since : Level_repr.t -> t -> Int32.t\n\nval remaining_blocks :\n Level_repr.t -> t -> blocks_per_voting_period:Int32.t -> Int32.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype kind = Proposal | Exploration | Cooldown | Promotion | Adoption\n\nlet string_of_kind = function\n | Proposal -> \"proposal\"\n | Exploration -> \"exploration\"\n | Cooldown -> \"cooldown\"\n | Promotion -> \"promotion\"\n | Adoption -> \"adoption\"\n\nlet pp_kind ppf kind = Format.fprintf ppf \"%s\" @@ string_of_kind kind\n\nlet kind_encoding =\n let open Data_encoding in\n union\n ~tag_size:`Uint8\n [\n case\n (Tag 0)\n ~title:\"Proposal\"\n (constant \"proposal\")\n (function Proposal -> Some () | _ -> None)\n (fun () -> Proposal);\n case\n (Tag 1)\n ~title:\"exploration\"\n (constant \"exploration\")\n (function Exploration -> Some () | _ -> None)\n (fun () -> Exploration);\n case\n (Tag 2)\n ~title:\"Cooldown\"\n (constant \"cooldown\")\n (function Cooldown -> Some () | _ -> None)\n (fun () -> Cooldown);\n case\n (Tag 3)\n ~title:\"Promotion\"\n (constant \"promotion\")\n (function Promotion -> Some () | _ -> None)\n (fun () -> Promotion);\n case\n (Tag 4)\n ~title:\"Adoption\"\n (constant \"adoption\")\n (function Adoption -> Some () | _ -> None)\n (fun () -> Adoption);\n ]\n\nlet succ_kind = function\n | Proposal -> Exploration\n | Exploration -> Cooldown\n | Cooldown -> Promotion\n | Promotion -> Adoption\n | Adoption -> Proposal\n\ntype voting_period = {index : int32; kind : kind; start_position : int32}\n\ntype t = voting_period\n\ntype info = {voting_period : t; position : int32; remaining : int32}\n\nlet root ~start_position = {index = 0l; kind = Proposal; start_position}\n\nlet pp ppf {index; kind; start_position} =\n Format.fprintf\n ppf\n \"@[<hv 2>index: %ld,@ kind:%a,@ start_position: %ld@]\"\n index\n pp_kind\n kind\n start_position\n\nlet pp_info ppf {voting_period; position; remaining} =\n Format.fprintf\n ppf\n \"@[<hv 2>voting_period: %a,@ position:%ld,@ remaining: %ld@]\"\n pp\n voting_period\n position\n remaining\n\nlet encoding =\n let open Data_encoding in\n conv\n (fun {index; kind; start_position} -> (index, kind, start_position))\n (fun (index, kind, start_position) -> {index; kind; start_position})\n (obj3\n (req\n \"index\"\n ~description:\n \"The voting period's index. Starts at 0 with the first block of \\\n the Alpha family of protocols.\"\n int32)\n (req\n ~description:\n \"One of the several kinds of periods in the voting procedure.\"\n \"kind\"\n kind_encoding)\n (req\n ~description:\n \"The relative position of the first level of the period with \\\n respect to the first level of the Alpha family of protocols.\"\n \"start_position\"\n int32))\n\nlet info_encoding =\n let open Data_encoding in\n conv\n (fun {voting_period; position; remaining} ->\n (voting_period, position, remaining))\n (fun (voting_period, position, remaining) ->\n {voting_period; position; remaining})\n (obj3\n (req\n ~description:\"The voting period to which the block belongs.\"\n \"voting_period\"\n encoding)\n (req\n ~description:\"The position of the block within the voting period.\"\n \"position\"\n int32)\n (req\n ~description:\n \"The number of blocks remaining till the end of the voting period.\"\n \"remaining\"\n int32))\n\ninclude Compare.Make (struct\n type nonrec t = t\n\n let compare p p' = Compare.Int32.compare p.index p'.index\nend)\n\nlet raw_reset period ~start_position =\n let index = Int32.succ period.index in\n let kind = Proposal in\n {index; kind; start_position}\n\nlet raw_succ period ~start_position =\n let index = Int32.succ period.index in\n let kind = succ_kind period.kind in\n {index; kind; start_position}\n\nlet position_since (level : Level_repr.t) (voting_period : t) =\n Int32.(sub level.level_position voting_period.start_position)\n\nlet remaining_blocks (level : Level_repr.t) (voting_period : t)\n ~blocks_per_voting_period =\n let position = position_since level voting_period in\n Int32.(sub blocks_per_voting_period (succ position))\n" ;
} ;
{ name = "Ticket_hash_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Ticket hashes are used to uniquely identify pairs made of\n Michelson ticktes and their owner.\n\n They are used by the protocol to keep record of a tickets ledger,\n that is how many tickets smart contracts own. More precisely, they\n are used as keys for the {!Storage.Ticket_balance} table. *)\n\n(** A ticket hash is computed by the function [make] and is a\n combination of a [ticketer], a [content type], a [content], and an\n [owner].\n\n {b Note:} This invariant can be invalidated if the [key_hash] is\n created from the [encoding]. *)\ntype t\n\nval encoding : t Data_encoding.t\n\nval pp : Format.formatter -> t -> unit\n\nval to_b58check : t -> string\n\nval of_b58check_opt : string -> t option\n\nval of_b58check_exn : string -> t\n\nval of_bytes_exn : bytes -> t\n\nval of_bytes_opt : bytes -> t option\n\ninclude Compare.S with type t := t\n\nval zero : t\n\nval of_script_expr_hash : Script_expr_hash.t -> t\n\nmodule Index : Storage_description.INDEX with type t = t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ninclude Script_expr_hash\n\nlet of_script_expr_hash t = t\n\nlet zero = zero\n\ninclude Compare.Make (struct\n type nonrec t = t\n\n let compare = compare\nend)\n\nmodule Index = Script_expr_hash\n" ;
} ;
{ name = "Manager_counter_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Counters are used as anti-replay protection mechanism in\n manager operations: each manager account stores a counter and\n each manager operation declares a value for the counter. When\n a manager operation is applied, the value of the counter of\n its manager is checked and incremented. *)\n\ninclude Compare.S\n\n(** Initial value for a counter (zero). *)\nval init : t\n\n(** Successor of a counter. *)\nval succ : t -> t\n\n(** Pretty-printer for counters. *)\nval pp : Format.formatter -> t -> unit\n\n(** Encoding for a counter to be used in {!Storage}. *)\nval encoding_for_storage : t Data_encoding.t\n\n(** Encoding for a counter to be used in {!Operation_repr}. *)\nval encoding_for_operation : t Data_encoding.t\n\n(** Encoding for a counter to be used in RPCs. *)\nval encoding_for_RPCs : t Data_encoding.t\n\n(** Encoding for a counter to be used in errors. *)\nval encoding_for_errors : t Data_encoding.t\n\n(** To be used in client injection only. *)\nmodule Internal_for_injection : sig\n (** Converts a string to a counter.\n Returns [None] if the string does not represent a valid counter. *)\n val of_string : string -> t option\nend\n\nmodule Internal_for_tests : sig\n val of_int : int -> t\n\n val to_int : t -> int\n\n val add : t -> int -> t\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ninclude Compare.Z\n\nlet init = Z.zero\n\nlet succ = Z.succ\n\nlet pp = Z.pp_print\n\nlet encoding_for_storage = Data_encoding.z\n\nlet encoding_for_operation = Data_encoding.(check_size 10 n)\n\nlet encoding_for_RPCs = Data_encoding.n\n\nlet encoding_for_errors = Data_encoding.z\n\nmodule Internal_for_injection = struct\n let of_string s =\n match Z.of_string s with\n | exception _ -> None\n | z -> if z < Z.zero then None else Some z\nend\n\nmodule Internal_for_tests = struct\n let of_int i =\n assert (Compare.Int.(i >= 0)) ;\n Z.of_int i\n\n let to_int = Z.to_int\n\n let add c i =\n let c = Z.(add c (of_int i)) in\n assert (c >= Z.zero) ;\n c\nend\n" ;
} ;
{ name = "Contract_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module defines identifiers for two basic types of contracts. It also\n specifies how to compute originated contract's hash from origination\n nonce. *)\n\n(** A contract is simply an account on the blockchain ledger. There are two\n types of contracts:\n - implicit contracts represent accounts of users of the blockchain;\n - originated are special accounts with a Michelson script attached to\n them. Every time a transaction is sent to an originated account, its\n associated script is run in order to trigger some action in response.\n\n An implicit account is identified by the hash of the public key which was\n used to create it. The owner of the corresponding private key is the\n holder of the account. An originated contract's hash is derived from its\n origination nonce (see below). *)\ntype t =\n | Implicit of Signature.Public_key_hash.t\n | Originated of Contract_hash.t\n\ninclude Compare.S with type t := t\n\nval in_memory_size : t -> Cache_memory_helpers.sint\n\n(** {2 Originated contracts} *)\n\n(** [originated_contract nonce] is the contract address originated from [nonce].\n*)\nval originated_contract : Origination_nonce.t -> t\n\n(** [originated_contracts ~since ~until] is the contract addresses originated\n from [since] until [until]. The operation hash of nonce [since] and [until]\n must be the same or it will fail with an [assert]. [since] < [until] or the\n returned list is empty *)\nval originated_contracts :\n since:Origination_nonce.t -> until:Origination_nonce.t -> Contract_hash.t list\n\n(** {2 Human readable notation} *)\n\ntype error += Invalid_contract_notation of string (* `Permanent *)\n\nval to_b58check : t -> string\n\nval of_b58check : string -> t tzresult\n\nval of_b58data : Base58.data -> t option\n\nval pp : Format.formatter -> t -> unit\n\nval pp_short : Format.formatter -> t -> unit\n\n(** {2 Serializers} *)\n\nval encoding : t Data_encoding.t\n\n(** [implicit_encoding] is an encoding for public key hashes that is\n compatible with the [encoding] of contracts for implicit accounts. *)\nval implicit_encoding : Signature.Public_key_hash.t Data_encoding.t\n\n(** [originated_encoding] is an encoding for contract hashes that is\n compatible with the [encoding] of contracts for originated accounts. *)\nval originated_encoding : Contract_hash.t Data_encoding.t\n\n(** [cases f g] exports the {!Data_encoding.cases} used to define {!encoding}.\n\n The only reason why we export that is to let {!Destination_repr.encoding}\n use it. This allows the latter to be compatible with {!encoding}, which\n is of key importance for backward compatibility reasons. *)\nval cases : ('a -> t option) -> (t -> 'a) -> 'a Data_encoding.case list\n\nval rpc_arg : t RPC_arg.arg\n\nmodule Index : Storage_description.INDEX with type t = t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t =\n | Implicit of Signature.Public_key_hash.t\n | Originated of Contract_hash.t\n\ninclude Compare.Make (struct\n type nonrec t = t\n\n let compare l1 l2 =\n match (l1, l2) with\n | Implicit pkh1, Implicit pkh2 ->\n Signature.Public_key_hash.compare pkh1 pkh2\n | Originated h1, Originated h2 -> Contract_hash.compare h1 h2\n | Implicit _, Originated _ -> -1\n | Originated _, Implicit _ -> 1\nend)\n\nlet in_memory_size =\n let open Cache_memory_helpers in\n function\n | Implicit _ -> h1w +! public_key_hash_in_memory_size\n | Originated _ -> h1w +! blake2b_hash_size\n\ntype error += Invalid_contract_notation of string (* `Permanent *)\n\nlet to_b58check = function\n | Implicit pbk -> Signature.Public_key_hash.to_b58check pbk\n | Originated h -> Contract_hash.to_b58check h\n\nlet implicit_of_b58data : Base58.data -> Signature.public_key_hash option =\n function\n | Ed25519.Public_key_hash.Data h -> Some (Signature.Ed25519 h)\n | Secp256k1.Public_key_hash.Data h -> Some (Signature.Secp256k1 h)\n | P256.Public_key_hash.Data h -> Some (Signature.P256 h)\n | Bls.Public_key_hash.Data h -> Some (Signature.Bls h)\n | _ -> None\n\nlet originated_of_b58data = function\n | Contract_hash.Data h -> Some h\n | _ -> None\n\nlet contract_of_b58data data =\n match implicit_of_b58data data with\n | Some pkh -> Some (Implicit pkh)\n | None -> (\n match originated_of_b58data data with\n | Some contract_hash -> Some (Originated contract_hash)\n | None -> None)\n\nlet of_b58check_gen ~of_b58data s =\n match Base58.decode s with\n | Some data -> (\n match of_b58data data with\n | Some c -> ok c\n | None -> error (Invalid_contract_notation s))\n | None -> error (Invalid_contract_notation s)\n\nlet of_b58check = of_b58check_gen ~of_b58data:contract_of_b58data\n\nlet pp ppf = function\n | Implicit pbk -> Signature.Public_key_hash.pp ppf pbk\n | Originated h -> Contract_hash.pp ppf h\n\nlet pp_short ppf = function\n | Implicit pbk -> Signature.Public_key_hash.pp_short ppf pbk\n | Originated h -> Contract_hash.pp_short ppf h\n\nlet implicit_case ~proj ~inj =\n let open Data_encoding in\n case (Tag 0) ~title:\"Implicit\" Signature.Public_key_hash.encoding proj inj\n\nlet originated_case ~proj ~inj =\n let open Data_encoding in\n case\n (Tag 1)\n (Fixed.add_padding Contract_hash.encoding 1)\n ~title:\"Originated\"\n proj\n inj\n\nlet cases is_contract to_contract =\n [\n implicit_case\n ~proj:(fun k ->\n match is_contract k with Some (Implicit k) -> Some k | _ -> None)\n ~inj:(fun k -> to_contract (Implicit k));\n originated_case\n ~proj:(fun k ->\n match is_contract k with Some (Originated k) -> Some k | _ -> None)\n ~inj:(fun k -> to_contract (Originated k));\n ]\n\nlet encoding_gen ~id_extra ~title_extra ~can_be ~cases ~to_b58check ~of_b58data\n =\n let open Data_encoding in\n def\n (\"contract_id\" ^ id_extra)\n ~title:(\"A contract handle\" ^ title_extra)\n ~description:\n (\"A contract notation as given to an RPC or inside scripts. Can be a \\\n base58 \" ^ can_be)\n @@ splitted\n ~binary:(union ~tag_size:`Uint8 @@ cases (fun x -> Some x) (fun x -> x))\n ~json:\n (conv\n to_b58check\n (fun s ->\n match of_b58check_gen ~of_b58data s with\n | Ok s -> s\n | Error _ -> Json.cannot_destruct \"Invalid contract notation.\")\n (string Plain))\n\nlet encoding =\n encoding_gen\n ~id_extra:\"\"\n ~title_extra:\"\"\n ~can_be:\"implicit contract hash or a base58 originated contract hash.\"\n ~cases\n ~to_b58check\n ~of_b58data:contract_of_b58data\n\nlet implicit_encoding =\n encoding_gen\n ~id_extra:\".implicit\"\n ~title_extra:\" -- implicit account\"\n ~can_be:\"implicit contract hash.\"\n ~cases:(fun proj inj -> [implicit_case ~proj ~inj])\n ~to_b58check:Signature.Public_key_hash.to_b58check\n ~of_b58data:implicit_of_b58data\n\nlet originated_encoding =\n encoding_gen\n ~id_extra:\".originated\"\n ~title_extra:\" -- originated account\"\n ~can_be:\"originated contract hash.\"\n ~cases:(fun proj inj -> [originated_case ~proj ~inj])\n ~to_b58check:Contract_hash.to_b58check\n ~of_b58data:originated_of_b58data\n\nlet () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"contract.invalid_contract_notation\"\n ~title:\"Invalid contract notation\"\n ~pp:(fun ppf x -> Format.fprintf ppf \"Invalid contract notation %S\" x)\n ~description:\n \"A malformed contract notation was given to an RPC or in a script.\"\n (obj1 (req \"notation\" (string Plain)))\n (function Invalid_contract_notation loc -> Some loc | _ -> None)\n (fun loc -> Invalid_contract_notation loc)\n\nlet originated_contract nonce = Originated (Contract_hash.of_nonce nonce)\n\nlet originated_contracts\n ~since:\n Origination_nonce.{origination_index = first; operation_hash = first_hash}\n ~until:\n (Origination_nonce.{origination_index = last; operation_hash = last_hash}\n as origination_nonce) =\n assert (Operation_hash.equal first_hash last_hash) ;\n let rec contracts acc origination_index =\n if Compare.Int32.(origination_index < first) then acc\n else\n let origination_nonce = {origination_nonce with origination_index} in\n let acc = Contract_hash.of_nonce origination_nonce :: acc in\n contracts acc (Int32.pred origination_index)\n in\n contracts [] (Int32.pred last)\n\nlet rpc_arg =\n let construct = to_b58check in\n let destruct hash =\n Result.map_error (fun _ -> \"Cannot parse contract id\") (of_b58check hash)\n in\n RPC_arg.make\n ~descr:\"A contract identifier encoded in b58check.\"\n ~name:\"contract_id\"\n ~construct\n ~destruct\n ()\n\nmodule Index = struct\n type nonrec t = t\n\n let path_length = 1\n\n let to_path c l =\n let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in\n let (`Hex key) = Hex.of_bytes raw_key in\n key :: l\n\n let of_path = function\n | [key] ->\n Option.bind\n (Hex.to_bytes (`Hex key))\n (Data_encoding.Binary.of_bytes_opt encoding)\n | _ -> None\n\n let rpc_arg = rpc_arg\n\n let encoding = encoding\n\n let compare = compare\nend\n\n(* Renamed exports. *)\n\nlet of_b58data = contract_of_b58data\n" ;
} ;
{ name = "Indexable" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** In transaction rollups, some values can be replaced by indexes in\n the messages sent from the layer-1 to the layer-2.\n\n This module provides various type-safe helpers to manipulate these\n particular values. *)\n\ntype value_only = Value_only\n\ntype index_only = Index_only\n\ntype unknown = Unknown\n\n(** An indexable value is a value which can be replaced by an\n integer. The first type parameter determines whether or not this\n replacement has happened already. *)\ntype (_, 'a) t = private\n | Value : 'a -> (value_only, 'a) t\n | Hidden_value : 'a -> (unknown, 'a) t\n | Index : int32 -> (index_only, 'a) t\n | Hidden_index : int32 -> (unknown, 'a) t\n\n(** The type of indexable values identified as not being indexes. *)\ntype 'a value = (value_only, 'a) t\n\n(** The type of indexable values identified as being indexes. *)\ntype 'a index = (index_only, 'a) t\n\n(** The type of indexable values whose content is still unknown. *)\ntype 'a either = (unknown, 'a) t\n\n(** [value v] wraps [v] into an indexable value identified as not\n being an index. *)\nval value : 'a -> 'a value\n\n(** [from_value v] wraps [v] into an indexable value, but forget about\n the nature of the content of the result. *)\nval from_value : 'a -> 'a either\n\n(** [index i] wraps [i] into an indexable value identified as being an\n index.\n\n Returns the error [Index_cannot_be_negative] iff [i <= 0l]. *)\nval index : int32 -> 'a index tzresult\n\n(** [from_index i] wraps [i] into an indexable value, but forget about the\n nature of the content of the result.\n\n Returns the error [Index_cannot_be_negative] iff [i <= 0l]. *)\nval from_index : int32 -> 'a either tzresult\n\n(** [index_exn i] wraps [i] into an indexable value identified as\n being an index.\n\n @raise Invalid_argument iff [i <= 0l]. *)\nval index_exn : int32 -> 'a index\n\n(** [from_index_exn i] wraps [i] into an indexable value, but forget\n about the nature of the content of the result.\n\n @raise Invalid_argument iff [i <= 0l]. *)\nval from_index_exn : int32 -> 'a either\n\n(** [compact val_encoding] is a combinator to derive a compact\n encoding for an indexable value of type ['a] from an encoding for\n ['a]. It uses two bits in the shared tag. [00] is used for indexes\n fitting in one byte, [01] for indexes fitting in two bytes, [10]\n for indexes fitting in four bytes, and [11] for the values of type\n ['a]. *)\nval compact : 'a Data_encoding.t -> (unknown, 'a) t Data_encoding.Compact.t\n\nval encoding : 'a Data_encoding.t -> (unknown, 'a) t Data_encoding.t\n\nval pp :\n (Format.formatter -> 'a -> unit) -> Format.formatter -> ('state, 'a) t -> unit\n\n(** [destruct x] returns either the index or the (unwrapped) value\n contained in [x].\n\n {b Note:} If you want to manipulate a value of type ['a value],\n you can use {!value}. *)\nval destruct : ('state, 'a) t -> ('a index, 'a) Either.t\n\n(** [forget x] returns an indexable value whose kind of contents has\n been forgotten. *)\nval forget : ('state, 'a) t -> (unknown, 'a) t\n\n(** [to_int32 x] unwraps and returns the integer behind [x]. *)\nval to_int32 : 'a index -> int32\n\n(** [to_value x] unwraps and returns the value behind [x]. *)\nval to_value : 'a value -> 'a\n\n(** [is_value_e err x] unwraps and returns the value behind [x], and\n throws an [err] if [x] is an index. *)\nval is_value_e : error:'trace -> ('state, 'a) t -> ('a, 'trace) result\n\n(** [in_memory_size a] returns the number of bytes allocated in RAM for [a]. *)\nval in_memory_size :\n ('a -> Cache_memory_helpers.sint) ->\n ('state, 'a) t ->\n Cache_memory_helpers.sint\n\n(** [size a] returns the number of bytes allocated in an inbox to store [a]. *)\nval size : ('a -> int) -> ('state, 'a) t -> int\n\n(** [compare f x y] is a total order on indexable values, which\n proceeds as follows.\n\n {ul {li If both [x] and [y] are a value, then use [f] to compare them.}\n {li If both [x] and [y] are indexes, then uses the\n [Int32.compare] function to compare them.}\n {li Finally, if [x] and [y] have not the same kind, the logic\n is that indexes are smaller than values.}}\n\n {b Note:} This can be dangerous, as you may end up comparing two\n things that are equivalent (a value and its index) but declare\n they are not equal. *)\nval compare : ('a -> 'a -> int) -> ('state, 'a) t -> ('state', 'a) t -> int\n\n(** [compare_values f x y] compares the value [x] and [y] using [f],\n and relies on the type system of OCaml to ensure that [x] and [y]\n are indeed both values. *)\nval compare_values : ('a -> 'a -> int) -> 'a value -> 'a value -> int\n\n(** [compare_indexes x y] compares the indexes [x] and [y], and relies\n on the type system of OCaml to ensure that [x] and [y] are indeed\n both indexes. *)\nval compare_indexes : 'a index -> 'a index -> int\n\nmodule type VALUE = sig\n type t\n\n val encoding : t Data_encoding.t\n\n val compare : t -> t -> int\n\n val pp : Format.formatter -> t -> unit\nend\n\nmodule Make (V : VALUE) : sig\n type nonrec 'state t = ('state, V.t) t\n\n type nonrec index = V.t index\n\n type nonrec value = V.t value\n\n type nonrec either = V.t either\n\n val value : V.t -> value\n\n val index : int32 -> index tzresult\n\n val index_exn : int32 -> index\n\n val compact : either Data_encoding.Compact.t\n\n val encoding : either Data_encoding.t\n\n val index_encoding : index Data_encoding.t\n\n val value_encoding : value Data_encoding.t\n\n val compare : 'state t -> 'state' t -> int\n\n val compare_values : value -> value -> int\n\n val compare_indexes : index -> index -> int\n\n val pp : Format.formatter -> 'state t -> unit\nend\n\ntype error += Index_cannot_be_negative of int32\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype index_only = Index_only\n\ntype value_only = Value_only\n\ntype unknown = Unknown\n\ntype (_, 'a) t =\n | Value : 'a -> (value_only, 'a) t\n | Hidden_value : 'a -> (unknown, 'a) t\n | Index : int32 -> (index_only, 'a) t\n | Hidden_index : int32 -> (unknown, 'a) t\n\ntype error += Index_cannot_be_negative of int32\n\nlet () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"indexable.index_cannot_be_negative\"\n ~title:\"Index of values cannot be negative\"\n ~description:\"A negative integer cannot be used as an index for a value.\"\n ~pp:(fun ppf wrong_id ->\n Format.fprintf\n ppf\n \"%ld cannot be used as an index because it is negative.\"\n wrong_id)\n (obj1 (req \"wrong_index\" int32))\n (function Index_cannot_be_negative wrong_id -> Some wrong_id | _ -> None)\n (fun wrong_id -> Index_cannot_be_negative wrong_id)\n\ntype 'a value = (value_only, 'a) t\n\ntype 'a index = (index_only, 'a) t\n\ntype 'a either = (unknown, 'a) t\n\nlet value : 'a -> 'a value = fun v -> Value v\n\nlet from_value : 'a -> 'a either = fun v -> Hidden_value v\n\nlet index : int32 -> 'a index tzresult =\n fun i ->\n if Compare.Int32.(0l <= i) then ok (Index i)\n else error (Index_cannot_be_negative i)\n\nlet from_index : int32 -> 'a either tzresult =\n fun i ->\n if Compare.Int32.(0l <= i) then ok (Hidden_index i)\n else error (Index_cannot_be_negative i)\n\nlet index_exn : int32 -> 'a index =\n fun i ->\n match index i with\n | Ok x -> x\n | Error _ -> raise (Invalid_argument \"Indexable.index_exn\")\n\nlet from_index_exn : int32 -> 'a either =\n fun i ->\n match from_index i with\n | Ok x -> x\n | Error _ -> raise (Invalid_argument \"Indexable.from_index_exn\")\n\nlet destruct : type state a. (state, a) t -> (a index, a) Either.t = function\n | Hidden_value x | Value x -> Right x\n | Hidden_index x | Index x -> Left (Index x)\n\nlet forget : type state a. (state, a) t -> (unknown, a) t = function\n | Hidden_value x | Value x -> Hidden_value x\n | Hidden_index x | Index x -> Hidden_index x\n\nlet to_int32 = function Index x -> x\n\nlet to_value = function Value x -> x\n\nlet is_value_e : error:'trace -> ('state, 'a) t -> ('a, 'trace) result =\n fun ~error v ->\n match destruct v with Left _ -> Result.error error | Right v -> Result.ok v\n\nlet compact val_encoding =\n Data_encoding.Compact.(\n conv\n (function Hidden_index x -> Either.Left x | Hidden_value x -> Right x)\n (function Left x -> Hidden_index x | Right x -> Hidden_value x)\n @@ or_int32 ~int32_title:\"index\" ~alt_title:\"value\" val_encoding)\n\nlet encoding : 'a Data_encoding.t -> 'a either Data_encoding.t =\n fun val_encoding ->\n Data_encoding.Compact.make ~tag_size:`Uint8 @@ compact val_encoding\n\nlet pp :\n type state a.\n (Format.formatter -> a -> unit) -> Format.formatter -> (state, a) t -> unit\n =\n fun ppv fmt -> function\n | Hidden_index x | Index x -> Format.(fprintf fmt \"#%ld\" x)\n | Hidden_value x | Value x -> Format.(fprintf fmt \"%a\" ppv x)\n\nlet in_memory_size :\n type state a.\n (a -> Cache_memory_helpers.sint) ->\n (state, a) t ->\n Cache_memory_helpers.sint =\n fun ims ->\n let open Cache_memory_helpers in\n function\n | Hidden_value x | Value x -> header_size +! word_size +! ims x\n | Hidden_index _ | Index _ -> header_size +! word_size +! int32_size\n\nlet size : type state a. (a -> int) -> (state, a) t -> int =\n fun s -> function\n | Hidden_value x | Value x -> 1 + s x\n | Hidden_index _ | Index _ -> (* tag + int32 *) 1 + 4\n\nlet compare :\n type state state' a. (a -> a -> int) -> (state, a) t -> (state', a) t -> int\n =\n fun c x y ->\n match (x, y) with\n | (Hidden_index x | Index x), (Hidden_index y | Index y) ->\n Compare.Int32.compare x y\n | (Hidden_value x | Value x), (Hidden_value y | Value y) -> c x y\n | (Hidden_index _ | Index _), (Hidden_value _ | Value _) -> -1\n | (Hidden_value _ | Value _), (Hidden_index _ | Index _) -> 1\n\nlet compare_values c : 'a value -> 'a value -> int =\n fun (Value x) (Value y) -> c x y\n\nlet compare_indexes : 'a index -> 'a index -> int =\n fun (Index x) (Index y) -> Compare.Int32.compare x y\n\nmodule type VALUE = sig\n type t\n\n val encoding : t Data_encoding.t\n\n val compare : t -> t -> int\n\n val pp : Format.formatter -> t -> unit\nend\n\nmodule Make (V : VALUE) = struct\n type nonrec 'state t = ('state, V.t) t\n\n type nonrec index = V.t index\n\n type nonrec value = V.t value\n\n type nonrec either = V.t either\n\n let value = value\n\n let index = index\n\n let index_exn = index_exn\n\n let compact = compact V.encoding\n\n let encoding = encoding V.encoding\n\n let index_encoding : index Data_encoding.t =\n Data_encoding.(\n conv (fun (Index x) -> x) (fun x -> Index x) Data_encoding.int32)\n\n let value_encoding : value Data_encoding.t =\n Data_encoding.(conv (fun (Value x) -> x) (fun x -> Value x) V.encoding)\n\n let pp : Format.formatter -> 'state t -> unit = fun fmt x -> pp V.pp fmt x\n\n let compare_values = compare_values V.compare\n\n let compare_indexes = compare_indexes\n\n let compare : 'state t -> 'state' t -> int = fun x y -> compare V.compare x y\nend\n" ;
} ;
{ name = "Entrypoint_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** An entrypoint is a non-empty string of at most 31 characters *)\ntype t\n\n(** Total ordering of entrypoints *)\nval compare : t -> t -> int\n\n(** Equality of entrypoints *)\nval ( = ) : t -> t -> bool\n\n(** Default entrypoint \"default\" *)\nval default : t\n\n(** Checks whether an entrypoint is the default entrypoint *)\nval is_default : t -> bool\n\n(** Root entrypoint \"root\" *)\nval root : t\n\n(** Checks whether an entrypoint is the root entrypoint *)\nval is_root : t -> bool\n\n(** Entrypoint \"do\" *)\nval do_ : t\n\n(** Entrypoint \"set_delegate\" *)\nval set_delegate : t\n\n(** Entrypoint \"remove_delegate\" *)\nval remove_delegate : t\n\n(** Deposit entrypoint \"deposit\" *)\nval deposit : t\n\n(** Checks whether an entrypoint is the deposit entrypoint *)\nval is_deposit : t -> bool\n\n(** Converts an annot to an entrypoint.\n Returns an error if the string is too long or is \"default\". *)\nval of_annot_strict :\n loc:Script_repr.location -> Non_empty_string.t -> t tzresult\n\n(** Converts a string to an entrypoint.\n Returns an error if the string is too long or is \"default\".\n Converts \"\" to \"default\". *)\nval of_string_strict : loc:Script_repr.location -> string -> t tzresult\n\n(** Converts a string to an entrypoint.\n Fails with [Invalid_arg] if the string is too long or is \"default\".\n Converts \"\" to \"default\". *)\nval of_string_strict_exn : string -> t\n\n(** Converts an annot to an entrypoint.\n Returns an error if the string is too long.\n Accepts \"default\". *)\nval of_annot_lax : Non_empty_string.t -> t tzresult\n\n(** Converts an annot to an entrypoint.\n Returns [None] if the string is too long.\n Accepts \"default\". *)\nval of_annot_lax_opt : Non_empty_string.t -> t option\n\n(** Converts a string to an entrypoint.\n Returns an error if the string is too long.\n Accepts \"default\" and converts \"\" to \"default\". *)\nval of_string_lax : string -> t tzresult\n\n(** Converts an entrypoint to a non-empty string.\n \"default\" is kept as is. *)\nval to_non_empty_string : t -> Non_empty_string.t\n\n(** Converts an entrypoint to a string.\n \"default\" is kept as is. *)\nval to_string : t -> string\n\n(** Converts an entrypoint to a string used as an address suffix.\n For the default entrypoint, the result is the empty string.\n Otherwise it is \"%\" followed by the entrypoint. *)\nval to_address_suffix : t -> string\n\n(** Converts an entrypoint to a string used as a field annotation of a\n parameter union type. It is \"%\" followed by the entrypoint.\n The default entrypoint is converted to \"%default\". *)\nval unparse_as_field_annot : t -> string\n\n(** Pretty-print an entrypoint *)\nval pp : Format.formatter -> t -> unit\n\n(** An encoding of entrypoints reusing the lax semantics.\n Decoding fails if the string is too long. \"\" is decoded into \"default\".\n \"default\" is encoded into \"default\". *)\nval simple_encoding : t Data_encoding.t\n\n(** An encoding of entrypoints reusing the strict semantics.\n Decoding fails if the string is too long or is \"default\".\n \"\" is decoded into \"default\".\n \"default\" is encoded into \"\". *)\nval value_encoding : t Data_encoding.t\n\n(** An optimized encoding of entrypoints, used for operations. *)\nval smart_encoding : t Data_encoding.t\n\n(** Entrypoint RPC arg. *)\nval rpc_arg : t RPC_arg.t\n\n(** In-memory size of an entrypoint *)\nval in_memory_size : t -> Saturation_repr.may_saturate Saturation_repr.t\n\n(** Set of entrypoints *)\nmodule Set : Set.S with type elt = t\n\n(** Map of entrypoints *)\nmodule Map : Map.S with type key = t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule Pre_entrypoint : sig\n (** Invariants on the string: 1 <= length <= 31 *)\n type t = private Non_empty_string.t\n\n val of_non_empty_string : Non_empty_string.t -> t option\nend = struct\n type t = Non_empty_string.t\n\n let of_non_empty_string (str : Non_empty_string.t) =\n if Compare.Int.(String.length (str :> string) > 31) then None else Some str\nend\n\ntype t = Pre_entrypoint.t\n\nlet compare (x : t) (y : t) =\n Non_empty_string.compare (x :> Non_empty_string.t) (y :> Non_empty_string.t)\n\nlet ( = ) (x : t) (y : t) =\n Non_empty_string.( = ) (x :> Non_empty_string.t) (y :> Non_empty_string.t)\n\ntype error += Name_too_long of string\n\nlet () =\n (* Entrypoint name too long *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.entrypoint_name_too_long\"\n ~title:\"Entrypoint name too long (type error)\"\n ~description:\n \"An entrypoint name exceeds the maximum length of 31 characters.\"\n Data_encoding.(obj1 (req \"name\" @@ string Plain))\n (function Name_too_long entrypoint -> Some entrypoint | _ -> None)\n (fun entrypoint -> Name_too_long entrypoint)\n\ntype error += Unexpected_default of Script_repr.location\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.unexpected_default_entrypoint\"\n ~title:\n \"The annotation 'default' was encountered where an entrypoint is expected\"\n ~description:\n \"A node in the syntax tree was improperly annotated. An annotation used \\\n to designate an entrypoint cannot be exactly 'default'.\"\n Data_encoding.(obj1 (req \"location\" Script_repr.location_encoding))\n (function Unexpected_default loc -> Some loc | _ -> None)\n (fun loc -> Unexpected_default loc)\n\nlet default =\n match\n Pre_entrypoint.of_non_empty_string\n @@ Non_empty_string.of_string_exn \"default\"\n with\n | None -> assert false\n | Some res -> res\n\nlet is_default name = name = default\n\ntype of_string_result =\n | Ok of t\n | Too_long (** length > 31 *)\n | Got_default\n (** Got exactly \"default\", which can be an error in some cases or OK in others *)\n\nlet of_non_empty_string (str : Non_empty_string.t) =\n match Pre_entrypoint.of_non_empty_string str with\n | None -> Too_long\n | Some str -> if is_default str then Got_default else Ok str\n\nlet of_string str =\n match Non_empty_string.of_string str with\n | None (* empty string *) ->\n (* The empty string always means the default entrypoint *)\n Ok default\n | Some str -> of_non_empty_string str\n\nlet of_string_strict ~loc str =\n match of_string str with\n | Too_long -> error (Name_too_long str)\n | Got_default -> error (Unexpected_default loc)\n | Ok name -> Ok name\n\nlet of_string_strict' str =\n match of_string str with\n | Too_long -> Error \"Entrypoint name too long\"\n | Got_default -> Error \"Unexpected annotation: default\"\n | Ok name -> Ok name\n\nlet of_string_strict_exn str =\n match of_string_strict' str with Ok v -> v | Error err -> invalid_arg err\n\nlet of_annot_strict ~loc a =\n match of_non_empty_string a with\n | Too_long -> error (Name_too_long (a :> string))\n | Got_default -> error (Unexpected_default loc)\n | Ok name -> Ok name\n\nlet of_annot_lax_opt a =\n match of_non_empty_string a with\n | Too_long -> None\n | Got_default -> Some default\n | Ok name -> Some name\n\nlet of_string_lax_opt str =\n match of_string str with\n | Too_long -> None\n | Got_default -> Some default\n | Ok name -> Some name\n\nlet of_string_lax str =\n match of_string_lax_opt str with\n | None -> error (Name_too_long str)\n | Some name -> Ok name\n\nlet of_annot_lax a =\n match of_non_empty_string a with\n | Too_long -> error (Name_too_long (a :> string))\n | Got_default -> Ok default\n | Ok name -> Ok name\n\nlet of_string_lax' str =\n match of_string_lax_opt str with\n | None -> Error (\"Entrypoint name too long \\\"\" ^ str ^ \"\\\"\")\n | Some name -> Ok name\n\nlet root = of_string_strict_exn \"root\"\n\nlet do_ = of_string_strict_exn \"do\"\n\nlet set_delegate = of_string_strict_exn \"set_delegate\"\n\nlet remove_delegate = of_string_strict_exn \"remove_delegate\"\n\nlet deposit = of_string_strict_exn \"deposit\"\n\nlet is_deposit = ( = ) deposit\n\nlet is_root = ( = ) root\n\nlet to_non_empty_string (name : t) = (name :> Non_empty_string.t)\n\nlet to_string (name : t) = (name :> string)\n\nlet to_address_suffix (name : t) =\n if is_default name then \"\" else \"%\" ^ (name :> string)\n\nlet unparse_as_field_annot (name : t) = \"%\" ^ (name :> string)\n\nlet of_string_lax_exn str =\n match of_string_lax' str with Ok name -> name | Error err -> invalid_arg err\n\nlet pp fmt (name : t) = Format.pp_print_string fmt (name :> string)\n\nlet simple_encoding =\n Data_encoding.conv_with_guard\n (fun (name : t) -> (name :> string))\n of_string_lax'\n Data_encoding.(string Plain)\n\nlet value_encoding =\n Data_encoding.conv_with_guard\n (fun name -> if is_default name then \"\" else (name :> string))\n of_string_strict'\n Data_encoding.Variable.(string Plain)\n\nlet smart_encoding =\n let open Data_encoding in\n def\n ~title:\"entrypoint\"\n ~description:\"Named entrypoint to a Michelson smart contract\"\n \"entrypoint\"\n @@\n let builtin_case tag (name : Pre_entrypoint.t) =\n case\n (Tag tag)\n ~title:(name :> string)\n (constant (name :> string))\n (fun n -> if n = name then Some () else None)\n (fun () -> name)\n in\n union\n [\n builtin_case 0 default;\n builtin_case 1 root;\n builtin_case 2 do_;\n builtin_case 3 set_delegate;\n builtin_case 4 remove_delegate;\n builtin_case 5 deposit;\n case\n (Tag 255)\n ~title:\"named\"\n (Bounded.string Plain 31)\n (fun (name : Pre_entrypoint.t) -> Some (name :> string))\n of_string_lax_exn;\n ]\n\nlet rpc_arg =\n RPC_arg.make\n ~descr:\"A Michelson entrypoint (string of length < 32)\"\n ~name:\"entrypoint\"\n ~construct:(fun (name : t) -> (name :> string))\n ~destruct:of_string_lax'\n ()\n\nlet in_memory_size (name : t) =\n Cache_memory_helpers.string_size_gen (String.length (name :> string))\n\nmodule T = struct\n type nonrec t = t\n\n let compare = compare\nend\n\nmodule Set = Set.Make (T)\nmodule Map = Map.Make (T)\n" ;
} ;
{ name = "Dal_slot_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** To verify the proof of a page membership in its associated slot, the\n Cryptobox module needs the following Dal parameters. These are part of the\n protocol's parameters. See {!Default_parameters.default_dal}. *)\ntype parameters = Dal.parameters = {\n redundancy_factor : int;\n page_size : int;\n slot_size : int;\n number_of_shards : int;\n}\n\n(** An encoding for values of type {!parameters}. *)\nval parameters_encoding : parameters Data_encoding.t\n\n(** Slot header representation for the data-availability layer.\n\n {1 Overview}\n\n For the data-availability layer, the L1 provides a list of slots\n at every level. A slot is a blob of data that can be interpreted by\n the users of the data-availability layer (such as SCORU).\n\n The purpose of the data-availability layer is to increase the\n bandwidth of the layer 1 thanks to the distribution of \"slots\". A\n slot is never posted directly onto the layer 1 blocks but on the\n data-availability layer. The producer of a slot still has to post a\n slot header onto the layer 1. A slot header is an abstract datatype\n certifying that the corresponding slot has some maximum size\n (provided by the layer 1). In other words, the whole data contained\n into the slot cannot exceed some fixed size. This is to avoid\n attacks where a slot header would be posted onto the layer 1 block,\n declared available by the protocol, but actually the slot size\n would be too large to be refuted a posteriori.\n\n The slot header can also be used to prove that a blob of data is a\n portion of the initial slot. *)\n\nmodule Commitment : sig\n (** A slot commitment is provided via the environment. *)\n type t = Dal.commitment\n\n val encoding : t Data_encoding.t\n\n (** A dummy value for a commitment. This commitment does not\n correspond to any valid pre-image. *)\n val zero : t\nend\n\nmodule Commitment_proof : sig\n (** A slot commitment proof is provided via the environment. *)\n type t = Dal.commitment_proof\n\n val encoding : t Data_encoding.t\n\n (** A dummy value for a commitment proof. *)\n val zero : t\nend\n\n(** An `Index.t` is a possible value for a slot index. We assume this value\n to be a positive 8-bit integer. Note that this is a hard constraint,\n which is independent of protocol constants. If a choice is ever made to\n increase the size of available slots in the protocol, we also need\n to change this module to accommodate for higher values.\n*)\nmodule Index : sig\n type t\n\n val encoding : t Data_encoding.t\n\n val pp : Format.formatter -> t -> unit\n\n val zero : t\n\n val max_value : t\n\n (** [of_int n] constructs a`Slot_index.t` *)\n val of_int : int -> t option\n\n val to_int : t -> int\n\n val compare : t -> t -> int\n\n val equal : t -> t -> bool\nend\n\nmodule Header : sig\n (** For Layer-1, a slot is identified by the level at which it is published\n and the slot's index. *)\n type id = {published_level : Raw_level_repr.t; index : Index.t}\n\n (** For Layer-1, a slot is described by its slot {!id} and the\n slot's commitment. *)\n type t = {id : id; commitment : Commitment.t}\n\n (** A \"publish slot header\" operation contains a slot header\n together with a proof that the slot size is smaller than\n [slot_size]. *)\n type operation = {header : t; proof : Commitment_proof.t}\n\n (** encoding for values of type {!id}. *)\n val id_encoding : id Data_encoding.t\n\n (** encoding for values of type {!t}. *)\n val encoding : t Data_encoding.t\n\n (** encoding for values of type {!operation}. *)\n val operation_encoding : operation Data_encoding.t\n\n (** pretty-printer for values of type {!id}. *)\n val pp_id : Format.formatter -> id -> unit\n\n (** pretty-printer for values of type {!t}. *)\n val pp : Format.formatter -> t -> unit\n\n (** equal function for values of type {!t}. *)\n val equal : t -> t -> bool\n\n (** check that for the given slot header operation, the commitment\n proof is correct wrt the commitment *)\n val verify_commitment : parameters -> operation -> bool tzresult\nend\n\n(** A DAL slot is decomposed to a successive list of pages with fixed content\n size. The size is chosen so that it's possible to inject a page in a Tezos\n L1 operation if needed during the proof phase of a refutation game.\n*)\nmodule Page : sig\n type content = Bytes.t\n\n type slot_index = Index.t\n\n val pages_per_slot : Dal.parameters -> int\n\n module Index : sig\n type t = int\n\n val zero : int\n\n val encoding : int Data_encoding.t\n\n val pp : Format.formatter -> int -> unit\n\n val compare : int -> int -> int\n\n val equal : int -> int -> bool\n end\n\n (** Encoding for page contents. *)\n val content_encoding : content Data_encoding.t\n\n (** A page is identified by its slot ID and by its own index in the list\n of pages of the slot. *)\n type t = {slot_id : Header.id; page_index : Index.t}\n\n type proof = Dal.page_proof\n\n (** equal function for values of type {!t}. *)\n val equal : t -> t -> bool\n\n (** encoding for values of type {!t}. *)\n val encoding : t Data_encoding.t\n\n (** encoding for values of type {!proof}. *)\n val proof_encoding : proof Data_encoding.t\n\n (** pretty-printer for values of type {!t}. *)\n val pp : Format.formatter -> t -> unit\nend\n\n(** Only one slot header is accepted per slot index. If two slots\n headers are included into a block, the second one will fail.\n\n Consequently, we rely on the order of operations which is done\n thanks to the fee market.\n\n This is encapsulated in the following module. *)\nmodule Slot_market : sig\n (** Represent the fee market for a list of slots. *)\n type t\n\n (** [init ~length] encodes a list of [length] slots without\n candidates. *)\n val init : length:int -> t\n\n (** [length t] returns the [length] provided at initialisation time\n (see {!val:init}). *)\n val length : t -> int\n\n (** [register t index fees] updates the candidate associated to\n index [index]. Returns [Some (_, true)] if the candidate is\n registered. Returns [Some (_, false)] otherwise. Returns [None]\n if the [index] is not in the interval [0;length] where [length]\n is the value provided to the [init] function. *)\n val register : t -> Header.t -> (t * bool) option\n\n (** [candidates t] returns a list of slot header candidates. *)\n val candidates : t -> Header.t list\nend\n\n(** This module provides an abstract data structure (type {!t}) that represents a\n skip list used to store successive DAL slots confirmed on L1. There is one\n slot per cell in the skip list. The slots are sorted in increasing order by\n level, and by slot index, for the slots of the same level.\n\n This module also defines a bounded history cache (type {History_cache.t})\n that allows to remember recent values of a skip list of type {!t}\n (indexed by the skip lists' hashes). This structure is meant to be\n maintained and used by the rollup node to produce refutation proofs\n involving DAL slot inputs.\n*)\nmodule History : sig\n (** Abstract representation of a skip list specialized for\n confirmed slot headers. *)\n type t\n\n module Pointer_hash : S.HASH\n\n (** Type of hashes of history. *)\n type hash = Pointer_hash.t\n\n (** Encoding of the datatype. *)\n val encoding : t Data_encoding.t\n\n (** First cell of this skip list. *)\n val genesis : t\n\n (** Returns the hash of an history. *)\n val hash : t -> hash\n\n (** The [History_cache.t] structure is basically a bounded lookup table of\n {!t} skip lists. (See {!Bounded_history_repr.S}). In the L1 layer, the\n capacity (bound) is set to zero (nothing is remembered). By contrast,\n the rollup node uses a history cache with a (sufficiently) large capacity\n to participate in all potential refutation games occurring during the\n challenge period. Indeed, the successive recent skip-lists stored in\n the cache are needed to produce proofs involving slots' pages. *)\n module History_cache :\n Bounded_history_repr.S with type key = hash and type value = t\n\n (** [add_confirmed_slots hist cache slot_headers] updates the given structure\n [hist] with the list of [slot_headers]. The given [cache] is also updated to\n add successive values of [cell] to it. *)\n val add_confirmed_slot_headers :\n t -> History_cache.t -> Header.t list -> (t * History_cache.t) tzresult\n\n (** [add_confirmed_slot_headers_no_cache cell slot_headers] same as\n {!add_confirmed_slot_headers}, but no cache is updated. *)\n val add_confirmed_slot_headers_no_cache : t -> Header.t list -> t tzresult\n\n (** [equal a b] returns true iff a is equal to b. *)\n val equal : t -> t -> bool\n\n (** {1 Dal slots/pages proofs} *)\n\n (** When a SCORU kernel's inputs come from the DAL, they are provided as\n pages' content for confirmed slots, or None in case the slot doesn't\n exist or is not confirmed.\n\n In a refutation game involving an import tick of a Dal page input, a\n honest user should be able to provide:\n\n - When the PVM is requesting a page of a confirmed slot: a proof that the\n slot is confirmed, in addition to needed information to check that the\n page (whose id and content are given) is part of the slot;\n\n - When the opponent pretends that the PVM is requesting a page of some\n unconfirmed slot, but that slot is not published or not confirmed on L1:\n a proof that the slot (whose id is given via the page's id) cannot be\n confirmed on L1.\n\n See the documentation in the ml file for more technical details. *)\n type proof\n\n (** Encoding for {!proof}. *)\n val proof_encoding : proof Data_encoding.t\n\n (** Pretty-printer for {!proof}. If [serialized] is [false] it will print\n the abstracted proof representation, otherwise if it's [true] it will\n print the serialized version of the proof (i.e. a sequence of bytes). *)\n val pp_proof : serialized:bool -> Format.formatter -> proof -> unit\n\n (** [produce_proof dal_parameters page_id page_info ~get_history slots_hist]\n produces a proof that either:\n - there exists a confirmed slot in the skip list that contains\n the page identified by [page_id] whose data and slot inclusion proof\n are given by [page_info], or\n - there cannot exist a confirmed slot in the skip list (whose head is\n given by [slots_hist]) containing the page identified by [page_id].\n\n In the first case above, [page_info] should contain the page's content\n and the proof that the page is part of the (confirmed) slot whose\n id is given in [page_id]. In the second case, no page content or proof\n should be provided, as they are not needed to construct a non-confirmation\n proof.\n\n [dal_parameters] is used when verifying that/if the page is part of\n the candidate slot (if any).\n *)\n val produce_proof :\n parameters ->\n Page.t ->\n page_info:(Page.content * Page.proof) option ->\n get_history:(hash -> t option Lwt.t) ->\n t ->\n (proof * Page.content option) tzresult Lwt.t\n\n (** [verify_proof dal_params page_id snapshot proof] verifies that the given\n [proof] is a valid proof to show that either:\n - the page identified by [page_id] belongs to a confirmed slot stored in\n the skip list whose head is [snapshot], or\n - there is not confirmed slot in the skip list (whose head is) [snapshot]\n that could contain the page identified by [page_id].\n\n [dal_parameters] is used when verifying that/if the page is part of\n the candidate slot (if any).\n *)\n val verify_proof :\n parameters -> Page.t -> t -> proof -> Page.content option tzresult\n\n type error += Add_element_in_slots_skip_list_violates_ordering\n\n type error +=\n | Dal_proof_error of string\n | Unexpected_page_size of {expected_size : int; page_size : int}\n\n module Internal_for_tests : sig\n val content : t -> Header.t\n\n (** [proof_statement_is serialized_proof expected] will return [true] if\n the deserialized proof and the [expected] proof shape match and [false]\n otherwise.\n Note that it will also return [false] if deserialization fails. *)\n val proof_statement_is : proof -> [`Confirmed | `Unconfirmed] -> bool\n end\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype parameters = Dal.parameters = {\n redundancy_factor : int;\n page_size : int;\n slot_size : int;\n number_of_shards : int;\n}\n\nlet parameters_encoding = Dal.parameters_encoding\n\nmodule Commitment = struct\n (* DAL/FIXME https://gitlab.com/tezos/tezos/-/issues/3389\n\n It is not clear whether the size of the slot associated to the\n commitment should be given here. *)\n type t = Dal.commitment\n\n let equal = Dal.Commitment.equal\n\n let encoding = Dal.Commitment.encoding\n\n let pp = Dal.Commitment.pp\n\n let zero = Dal.Commitment.zero\nend\n\nmodule Commitment_proof = struct\n type t = Dal.commitment_proof\n\n let encoding = Dal.Commitment_proof.encoding\n\n let zero = Dal.Commitment_proof.zero\nend\n\nmodule Index = struct\n type t = int\n\n let max_value = 255\n\n let encoding = Data_encoding.uint8\n\n let pp = Format.pp_print_int\n\n let zero = 0\n\n let of_int slot_index =\n if Compare.Int.(slot_index <= max_value && slot_index >= zero) then\n Some slot_index\n else None\n\n let to_int slot_index = slot_index [@@ocaml.inline always]\n\n let compare = Compare.Int.compare\n\n let equal = Compare.Int.equal\nend\n\nmodule Header = struct\n type id = {published_level : Raw_level_repr.t; index : Index.t}\n\n type t = {id : id; commitment : Commitment.t}\n\n type operation = {header : t; proof : Commitment_proof.t}\n\n let slot_id_equal {published_level; index} s2 =\n Raw_level_repr.equal published_level s2.published_level\n && Index.equal index s2.index\n\n let equal {id; commitment} s2 =\n slot_id_equal id s2.id && Commitment.equal commitment s2.commitment\n\n let compare_slot_id {published_level; index} s2 =\n let c = Raw_level_repr.compare published_level s2.published_level in\n if Compare.Int.(c <> 0) then c else Index.compare index s2.index\n\n let zero_id =\n {\n (* We don't expect to have any published slot at level\n Raw_level_repr.root. *)\n published_level = Raw_level_repr.root;\n index = Index.zero;\n }\n\n let zero = {id = zero_id; commitment = Commitment.zero}\n\n let id_encoding =\n let open Data_encoding in\n conv\n (fun {published_level; index} -> (published_level, index))\n (fun (published_level, index) -> {published_level; index})\n (obj2\n (req \"level\" Raw_level_repr.encoding)\n (req \"index\" Data_encoding.uint8))\n\n let encoding =\n let open Data_encoding in\n conv\n (fun {id; commitment} -> (id, commitment))\n (fun (id, commitment) -> {id; commitment})\n (merge_objs id_encoding (obj1 (req \"commitment\" Commitment.encoding)))\n\n let operation_encoding =\n let open Data_encoding in\n conv\n (fun {header = {id; commitment}; proof} -> (id, (commitment, proof)))\n (fun (id, (commitment, proof)) -> {header = {id; commitment}; proof})\n (merge_objs\n id_encoding\n (obj2\n (req \"commitment\" Commitment.encoding)\n (req \"commitment_proof\" Commitment_proof.encoding)))\n\n let pp_id fmt {published_level; index} =\n Format.fprintf\n fmt\n \"published_level: %a, index: %a\"\n Raw_level_repr.pp\n published_level\n Format.pp_print_int\n index\n\n let pp fmt {id; commitment = c} =\n Format.fprintf fmt \"id:(%a), commitment: %a\" pp_id id Commitment.pp c\n\n type error += Dal_commitment_proof_error of string\n\n let () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"dal_slot_repr.dal_commitment_proof_error\"\n ~title:\"Dal commitment proof error\"\n ~description:\"Error occurred during Dal commitment proof validation\"\n ~pp:(fun ppf e -> Format.fprintf ppf \"Dal commitment proof error: %s\" e)\n (obj1 (req \"error\" (string Plain)))\n (function Dal_commitment_proof_error e -> Some e | _ -> None)\n (fun e -> Dal_commitment_proof_error e)\n\n let verify_commitment dal_params {header = {commitment; _}; proof} =\n let open Result_syntax in\n let* dal =\n match Dal.make dal_params with\n | Ok dal -> return dal\n | Error (`Fail s) -> error (Dal_commitment_proof_error s)\n in\n return @@ Dal.verify_commitment dal commitment proof\nend\n\nmodule Slot_index = Index\n\nmodule Page = struct\n type content = Bytes.t\n\n type slot_index = Index.t\n\n let pages_per_slot = Dal.pages_per_slot\n\n module Index = struct\n type t = int\n\n let zero = 0\n\n let encoding = Data_encoding.int16\n\n let pp = Format.pp_print_int\n\n let compare = Compare.Int.compare\n\n let equal = Compare.Int.equal\n end\n\n type t = {slot_id : Header.id; page_index : Index.t}\n\n type proof = Dal.page_proof\n\n let encoding =\n let open Data_encoding in\n conv\n (fun {slot_id = {published_level; index}; page_index} ->\n (published_level, index, page_index))\n (fun (published_level, index, page_index) ->\n {slot_id = {published_level; index}; page_index})\n (obj3\n (req \"published_level\" Raw_level_repr.encoding)\n (req \"slot_index\" Slot_index.encoding)\n (req \"page_index\" Index.encoding))\n\n let equal {slot_id; page_index} p =\n Header.slot_id_equal slot_id p.slot_id\n && Index.equal page_index p.page_index\n\n let proof_encoding = Dal.page_proof_encoding\n\n let content_encoding = Data_encoding.(bytes Hex)\n\n let pp fmt {slot_id = {published_level; index}; page_index} =\n Format.fprintf\n fmt\n \"(published_level: %a, slot_index: %a, page_index: %a)\"\n Raw_level_repr.pp\n published_level\n Slot_index.pp\n index\n Index.pp\n page_index\n\n let pp_proof fmt proof =\n Data_encoding.Json.pp\n fmt\n (Data_encoding.Json.construct proof_encoding proof)\nend\n\nmodule Slot_market = struct\n (* DAL/FIXME https://gitlab.com/tezos/tezos/-/issues/3108\n\n Think harder about this data structure and whether it can be\n optimized. *)\n\n module Slot_index_map = Map.Make (Index)\n\n type t = {length : int; slot_headers : Header.t Slot_index_map.t}\n\n let init ~length =\n if Compare.Int.(length < 0) then\n invalid_arg \"Dal_slot_repr.Slot_market.init: length cannot be negative\" ;\n let slot_headers = Slot_index_map.empty in\n {length; slot_headers}\n\n let length {length; _} = length\n\n let register t new_slot_header =\n let open Header in\n if\n not\n Compare.Int.(\n 0 <= new_slot_header.id.index && new_slot_header.id.index < t.length)\n then None\n else\n let has_changed = ref false in\n let update = function\n | None ->\n has_changed := true ;\n Some new_slot_header\n | Some x -> Some x\n in\n let slot_headers =\n Slot_index_map.update new_slot_header.id.index update t.slot_headers\n in\n let t = {t with slot_headers} in\n Some (t, !has_changed)\n\n let candidates t =\n t.slot_headers |> Slot_index_map.to_seq |> Seq.map snd |> List.of_seq\nend\n\nmodule History = struct\n (* History is represented via a skip list. The content of the cell\n is the hash of a merkle proof. *)\n\n (* A leaf of the merkle tree is a slot. *)\n module Leaf = struct\n type t = Header.t\n\n let to_bytes = Data_encoding.Binary.to_bytes_exn Header.encoding\n end\n\n module Content_prefix = struct\n let (_prefix : string) = \"dash1\"\n\n (* 32 *)\n let b58check_prefix = \"\\002\\224\\072\\094\\219\" (* dash1(55) *)\n\n let size = Some 32\n\n let name = \"dal_skip_list_content\"\n\n let title = \"A hash to represent the content of a cell in the skip list\"\n end\n\n module Content_hash = Blake2B.Make (Base58) (Content_prefix)\n module Merkle_list = Merkle_list.Make (Leaf) (Content_hash)\n\n (* Pointers of the skip lists are used to encode the content and the\n backpointers. *)\n module Pointer_prefix = struct\n let (_prefix : string) = \"dask1\"\n\n (* 32 *)\n let b58check_prefix = \"\\002\\224\\072\\115\\035\" (* dask1(55) *)\n\n let size = Some 32\n\n let name = \"dal_skip_list_pointer\"\n\n let title = \"A hash that represents the skip list pointers\"\n end\n\n module Pointer_hash = Blake2B.Make (Base58) (Pointer_prefix)\n\n module Skip_list_parameters = struct\n let basis = 4\n end\n\n type error += Add_element_in_slots_skip_list_violates_ordering\n\n let () =\n register_error_kind\n `Temporary\n ~id:\"Dal_slot_repr.add_element_in_slots_skip_list_violates_ordering\"\n ~title:\"Add an element in slots skip list that violates ordering\"\n ~description:\n \"Attempting to add an element on top of the Dal confirmed slots skip \\\n list that violates the ordering.\"\n Data_encoding.unit\n (function\n | Add_element_in_slots_skip_list_violates_ordering -> Some ()\n | _ -> None)\n (fun () -> Add_element_in_slots_skip_list_violates_ordering)\n\n module Skip_list = struct\n include Skip_list_repr.Make (Skip_list_parameters)\n\n (** All confirmed DAL slots will be stored in a skip list, where only the\n last cell is remembered in the L1 context. The skip list is used in\n the proof phase of a refutation game to verify whether a given slot\n exists (i.e., confirmed) or not in the skip list. The skip list is\n supposed to be sorted, as its 'search' function explicitly uses a given\n `compare` function during the list traversal to quickly (in log(size))\n reach the target if any.\n\n In our case, we will store one slot per cell in the skip list and\n maintain that the list is well sorted (and without redundancy) w.r.t.\n the [compare_slot_id] function.\n\n Below, we redefine the [next] function (that allows adding elements\n on top of the list) to enforce that the constructed skip list is\n well-sorted. We also define a wrapper around the search function to\n guarantee that it can only be called with the adequate compare function.\n *)\n\n let next ~prev_cell ~prev_cell_ptr elt =\n let open Result_syntax in\n let* () =\n error_when\n (Compare.Int.( <= )\n (Header.compare_slot_id\n elt.Header.id\n (content prev_cell).Header.id)\n 0)\n Add_element_in_slots_skip_list_violates_ordering\n in\n return @@ next ~prev_cell ~prev_cell_ptr elt\n\n let search ~deref ~cell ~target_id =\n Lwt.search ~deref ~cell ~compare:(fun slot ->\n Header.compare_slot_id slot.Header.id target_id)\n end\n\n module V1 = struct\n (* The content of a cell is the hash of all the slot commitments\n represented as a merkle list. *)\n (* TODO/DAL: https://gitlab.com/tezos/tezos/-/issues/3765\n Decide how to store attested slots in the skip list's content. *)\n type content = Header.t\n\n (* A pointer to a cell is the hash of its content and all the back\n pointers. *)\n type hash = Pointer_hash.t\n\n type history = (content, hash) Skip_list.cell\n\n type t = history\n\n let history_encoding =\n Skip_list.encoding Pointer_hash.encoding Header.encoding\n\n let equal_history : history -> history -> bool =\n Skip_list.equal Pointer_hash.equal Header.equal\n\n let encoding = history_encoding\n\n let equal : t -> t -> bool = equal_history\n\n let genesis : t = Skip_list.genesis Header.zero\n\n let hash cell =\n let current_slot = Skip_list.content cell in\n let back_pointers_hashes = Skip_list.back_pointers cell in\n Data_encoding.Binary.to_bytes_exn Header.encoding current_slot\n :: List.map Pointer_hash.to_bytes back_pointers_hashes\n |> Pointer_hash.hash_bytes\n\n let pp_history fmt (history : history) =\n let history_hash = hash history in\n Format.fprintf\n fmt\n \"@[hash : %a@;%a@]\"\n Pointer_hash.pp\n history_hash\n (Skip_list.pp ~pp_content:Header.pp ~pp_ptr:Pointer_hash.pp)\n history\n\n module History_cache =\n Bounded_history_repr.Make\n (struct\n let name = \"dal_slots_cache\"\n end)\n (Pointer_hash)\n (struct\n type t = history\n\n let encoding = history_encoding\n\n let pp = pp_history\n\n let equal = equal_history\n end)\n\n let add_confirmed_slot_header (t, cache) slot_header =\n let open Result_syntax in\n let prev_cell_ptr = hash t in\n let* cache = History_cache.remember prev_cell_ptr t cache in\n let* new_cell = Skip_list.next ~prev_cell:t ~prev_cell_ptr slot_header in\n return (new_cell, cache)\n\n let add_confirmed_slot_headers (t : t) cache slot_headers =\n List.fold_left_e add_confirmed_slot_header (t, cache) slot_headers\n\n let add_confirmed_slot_headers_no_cache =\n let no_cache = History_cache.empty ~capacity:0L in\n fun t slots ->\n List.fold_left_e add_confirmed_slot_header (t, no_cache) slots >|? fst\n\n (* Dal proofs section *)\n\n (** An inclusion proof, for a page ID, is a list of the slots' history\n skip list's cells that encodes a minimal path:\n - from a starting cell, which serves as a reference. It is usually called\n 'snapshot' below,\n - to a final cell, that is either the exact target cell in case the slot\n of the page is confirmed, or a cell whose slot ID is the smallest\n that directly follows the page's slot id, in case the target slot\n is not confirmed.\n\n Using the starting cell as a trustable starting point (i.e. maintained\n and provided by L1), and combined with the extra information stored in\n the {!proof} type below, one can verify if a slot (and then a page of\n that slot) is confirmed on L1 or not. *)\n type inclusion_proof = history list\n\n (** (See the documentation in the mli file to understand what we want to\n prove in game refutation involving Dal and why.)\n\n A Dal proof is an algebraic datatype with two cases, where we basically\n prove that a Dal page is confirmed on L1 or not. Being 'not confirmed'\n here includes the case where the slot's header is not published and the\n case where the slot's header is published, but the endorsers didn't\n confirm the availability of its data.\n\n To produce a proof representation for a page (see function {!produce_proof_repr}\n below), we assume given:\n\n - [page_id], identifies the page;\n\n - [slots_history], a current/recent cell of the slots history skip list.\n Typically, it should be the skip list cell snapshotted when starting the\n refutation game;\n\n - [history_cache], a sufficiently large slots history cache, to navigate\n back through the successive cells of the skip list. Typically,\n the cache should at least contain the cell whose slot ID is [page_id.slot_id]\n in case the page is confirmed, or the cell whose slot ID is immediately\n after [page_id.slot_id] in case of an unconfirmed page. Indeed,\n inclusion proofs encode paths through skip lists' cells where the head\n is the reference/snapshot cell and the last element is the target slot\n in or the nearest upper slot (w.r.t [page_id]'s slot id and to\n skip list elements ordering) ;\n\n - [page_info], that provides the page's information (the content and\n the slot membership proof) for page_id. In case the page is supposed\n to be confirmed, this argument should contain the page's content and\n the proof that the page is part of the (confirmed) slot whose ID is\n given in [page_id]. In case we want to show that the page is not confirmed,\n the value [page_info] should be [None].\n\n [dal_parameters] is used when verifying that/if the page is part of\n the candidate slot (if any).\n\n\n*)\n type proof_repr =\n | Page_confirmed of {\n target_cell : history;\n (** [target_cell] is a cell whose content contains the slot to\n which the page belongs to. *)\n inc_proof : inclusion_proof;\n (** [inc_proof] is a (minimal) path in the skip list that proves\n cells inclusion. The head of the list is the [slots_history]\n provided to produce the proof. The last cell's content is\n the slot containing the page identified by [page_id],\n that is: [target_cell]. *)\n page_data : Page.content;\n (** [page_data] is the content of the page. *)\n page_proof : Page.proof;\n (** [page_proof] is the proof that the page whose content is\n [page_data] is actually the [page_id.page_index]th page of\n the slot stored in [target_cell] and identified by\n page_id.slot_id. *)\n } (** The case where the slot's page is confirmed/attested on L1. *)\n | Page_unconfirmed of {\n prev_cell : history;\n (** [prev_cell] is the cell of the skip list containing a\n (confirmed) slot, and whose ID is the biggest (w.r.t. to skip\n list elements ordering), but smaller than [page_id.slot_id]. *)\n next_cell_opt : history option;\n (** [next_cell_opt] is the cell that immediately follows [prev_cell]\n in the skip list, if [prev_cell] is not the latest element in\n the list. Otherwise, it's set to [None]. *)\n next_inc_proof : inclusion_proof;\n (** [inc_proof] is a (minimal) path in the skip list that proves\n cells inclusion. In case, [next_cell_opt] contains some cell\n 'next_cell', the head of the list is the [slots_history]\n provided to produce the proof, and the last cell is\n 'next_cell'. In case [next_cell_opt] is [None], the list is\n empty.\n\n We maintain the following invariant in case the inclusion\n proof is not empty:\n ```\n (content next_cell).id > page_id.slot_id > (content prev_cell).id AND\n hash prev_cell = back_pointer next_cell 0 AND\n Some next_cell = next_cell_opt AND\n head next_inc_proof = slots_history\n ```\n\n Said differently, `next_cell` and `prev_cell` are two consecutive\n cells of the skip list whose contents' IDs surround the page's\n slot ID. Moreover, the head of the list should be equal to\n the initial (snapshotted) slots_history skip list.\n\n The case of an empty inclusion proof happens when the inputs\n are such that: `page_id.slot_id > (content slots_history).id`.\n The returned proof statement implies the following property in this case:\n\n ```\n next_cell_opt = None AND prev_cell = slots_history\n ```\n *)\n }\n (** The case where the slot's page doesn't exist or is not\n confirmed on L1. *)\n\n let proof_repr_encoding =\n let open Data_encoding in\n let case_page_confirmed =\n case\n ~title:\"confirmed dal page proof representation\"\n (Tag 0)\n (obj5\n (req \"kind\" (constant \"confirmed\"))\n (req \"target_cell\" history_encoding)\n (req \"inc_proof\" (list history_encoding))\n (req \"page_data\" (bytes Hex))\n (req \"page_proof\" Page.proof_encoding))\n (function\n | Page_confirmed {target_cell; inc_proof; page_data; page_proof} ->\n Some ((), target_cell, inc_proof, page_data, page_proof)\n | _ -> None)\n (fun ((), target_cell, inc_proof, page_data, page_proof) ->\n Page_confirmed {target_cell; inc_proof; page_data; page_proof})\n and case_page_unconfirmed =\n case\n ~title:\"unconfirmed dal page proof representation\"\n (Tag 1)\n (obj4\n (req \"kind\" (constant \"unconfirmed\"))\n (req \"prev_cell\" history_encoding)\n (req \"next_cell_opt\" (option history_encoding))\n (req \"next_inc_proof\" (list history_encoding)))\n (function\n | Page_unconfirmed {prev_cell; next_cell_opt; next_inc_proof} ->\n Some ((), prev_cell, next_cell_opt, next_inc_proof)\n | _ -> None)\n (fun ((), prev_cell, next_cell_opt, next_inc_proof) ->\n Page_unconfirmed {prev_cell; next_cell_opt; next_inc_proof})\n in\n\n union [case_page_confirmed; case_page_unconfirmed]\n\n (** Proof's type is set to bytes and not a structural datatype because\n when a proof appears in a tezos operation or in an rpc, a user can not\n reasonably understand the proof, thus it eases the work of people decoding\n the proof by only supporting bytes and not the whole structured proof. *)\n\n type proof = bytes\n\n (** DAL/FIXME: https://gitlab.com/tezos/tezos/-/issues/4084\n DAL proof's encoding should be bounded *)\n let proof_encoding = Data_encoding.(bytes Hex)\n\n type error += Dal_invalid_proof_serialization\n\n let () =\n register_error_kind\n `Permanent\n ~id:\"Dal_slot_repr.invalid_proof_serialization\"\n ~title:\"Dal invalid proof serialization\"\n ~description:\"Error occured during dal proof serialization\"\n Data_encoding.unit\n (function Dal_invalid_proof_serialization -> Some () | _ -> None)\n (fun () -> Dal_invalid_proof_serialization)\n\n let serialize_proof proof =\n match Data_encoding.Binary.to_bytes_opt proof_repr_encoding proof with\n | None -> error Dal_invalid_proof_serialization\n | Some serialized_proof -> ok serialized_proof\n\n type error += Dal_invalid_proof_deserialization\n\n let () =\n register_error_kind\n `Permanent\n ~id:\"Dal_slot_repr.invalid_proof_deserialization\"\n ~title:\"Dal invalid proof deserialization\"\n ~description:\"Error occured during dal proof deserialization\"\n Data_encoding.unit\n (function Dal_invalid_proof_deserialization -> Some () | _ -> None)\n (fun () -> Dal_invalid_proof_deserialization)\n\n let deserialize_proof proof =\n match Data_encoding.Binary.of_bytes_opt proof_repr_encoding proof with\n | None -> error Dal_invalid_proof_deserialization\n | Some deserialized_proof -> ok deserialized_proof\n\n let pp_inclusion_proof = Format.pp_print_list pp_history\n\n let pp_history_opt = Format.pp_print_option pp_history\n\n let pp_proof ~serialized fmt p =\n if serialized then Format.pp_print_string fmt (Bytes.to_string p)\n else\n match deserialize_proof p with\n | Error msg -> Error_monad.pp_trace fmt msg\n | Ok proof -> (\n match proof with\n | Page_confirmed {target_cell; inc_proof; page_data; page_proof} ->\n Format.fprintf\n fmt\n \"Page_confirmed (target_cell=%a, data=%s,@ \\\n inc_proof:[size=%d |@ path=%a]@ page_proof:%a)\"\n pp_history\n target_cell\n (Bytes.to_string page_data)\n (List.length inc_proof)\n pp_inclusion_proof\n inc_proof\n Page.pp_proof\n page_proof\n | Page_unconfirmed {prev_cell; next_cell_opt; next_inc_proof} ->\n Format.fprintf\n fmt\n \"Page_unconfirmed (prev_cell = %a | next_cell = %a | \\\n prev_inc_proof:[size=%d@ | path=%a])\"\n pp_history\n prev_cell\n pp_history_opt\n next_cell_opt\n (List.length next_inc_proof)\n pp_inclusion_proof\n next_inc_proof)\n\n type error +=\n | Dal_proof_error of string\n | Unexpected_page_size of {expected_size : int; page_size : int}\n\n let () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"dal_slot_repr.slots_history.dal_proof_error\"\n ~title:\"Dal proof error\"\n ~description:\"Error occurred during Dal proof production or validation\"\n ~pp:(fun ppf e -> Format.fprintf ppf \"Dal proof error: %s\" e)\n (obj1 (req \"error\" (string Plain)))\n (function Dal_proof_error e -> Some e | _ -> None)\n (fun e -> Dal_proof_error e)\n\n let () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"dal_slot_repr.slots_history.unexpected_page_size\"\n ~title:\"Unexpected page size\"\n ~description:\n \"The size of the given page content doesn't match the expected one.\"\n ~pp:(fun ppf (expected, size) ->\n Format.fprintf\n ppf\n \"The size of a Dal page is expected to be %d bytes. The given one \\\n has %d\"\n expected\n size)\n (obj2 (req \"expected_size\" int16) (req \"page_size\" int16))\n (function\n | Unexpected_page_size {expected_size; page_size} ->\n Some (expected_size, page_size)\n | _ -> None)\n (fun (expected_size, page_size) ->\n Unexpected_page_size {expected_size; page_size})\n\n let dal_proof_error reason = Dal_proof_error reason\n\n let proof_error reason = error @@ dal_proof_error reason\n\n let check_page_proof dal_params proof data ({Page.page_index; _} as pid)\n commitment =\n let open Result_syntax in\n let* dal =\n match Dal.make dal_params with\n | Ok dal -> return dal\n | Error (`Fail s) -> proof_error s\n in\n let fail_with_error_msg what =\n Format.kasprintf proof_error \"%s (page id=%a).\" what Page.pp pid\n in\n match Dal.verify_page dal commitment ~page_index data proof with\n | Ok true -> return ()\n | Ok false ->\n fail_with_error_msg\n \"Wrong page content for the given page index and slot commitment\"\n | Error `Segment_index_out_of_range ->\n fail_with_error_msg \"Segment_index_out_of_range\"\n | Error `Page_length_mismatch ->\n tzfail\n @@ Unexpected_page_size\n {\n expected_size = dal_params.page_size;\n page_size = Bytes.length data;\n }\n\n let produce_proof_repr dal_params page_id ~page_info ~get_history slots_hist\n =\n let open Lwt_result_syntax in\n let Page.{slot_id; page_index = _} = page_id in\n (* We search for a slot whose ID is equal to target_id. *)\n let*! search_result =\n Skip_list.search ~deref:get_history ~target_id:slot_id ~cell:slots_hist\n in\n match (page_info, search_result.Skip_list.last_cell) with\n | _, Deref_returned_none ->\n tzfail\n @@ dal_proof_error\n \"Skip_list.search returned 'Deref_returned_none': Slots history \\\n cache is ill-formed or has too few entries.\"\n | _, No_exact_or_lower_ptr ->\n tzfail\n @@ dal_proof_error\n \"Skip_list.search returned 'No_exact_or_lower_ptr', while it is \\\n initialized with a min elt (slot zero).\"\n | Some (page_data, page_proof), Found target_cell ->\n (* The slot to which the page is supposed to belong is found. *)\n let Header.{id; commitment} = Skip_list.content target_cell in\n (* We check that the slot is not the dummy slot. *)\n let*? () =\n error_when\n Compare.Int.(Header.compare_slot_id id Header.zero.id = 0)\n (dal_proof_error\n \"Skip_list.search returned 'Found <zero_slot>': No existence \\\n proof should be constructed with the slot zero.\")\n in\n let*? () =\n check_page_proof dal_params page_proof page_data page_id commitment\n in\n let inc_proof = List.rev search_result.Skip_list.rev_path in\n let*? () =\n error_when\n (List.is_empty inc_proof)\n (dal_proof_error \"The inclusion proof cannot be empty\")\n in\n (* All checks succeeded. We return a `Page_confirmed` proof. *)\n return\n ( Page_confirmed {inc_proof; target_cell; page_data; page_proof},\n Some page_data )\n | None, Nearest {lower = prev_cell; upper = next_cell_opt} ->\n (* There is no previously confirmed slot in the skip list whose ID\n corresponds to the {published_level; slot_index} information\n given in [page_id]. But, `search` returned a skip list [prev_cell]\n (and possibly [next_cell_opt]) such that:\n - the ID of [prev_cell]'s slot is the biggest immediately smaller than\n the page's information {published_level; slot_index}\n - if not equal to [None], the ID of [next_cell_opt]'s slot is the smallest\n immediately bigger than the page's slot id `slot_id`.\n - if [next_cell_opt] is [None] then, [prev_cell] should be equal to\n the given history_proof cell. *)\n let* next_inc_proof =\n match search_result.Skip_list.rev_path with\n | [] -> assert false (* Not reachable *)\n | prev :: rev_next_inc_proof ->\n let*? () =\n error_unless\n (equal_history prev prev_cell)\n (dal_proof_error\n \"Internal error: search's Nearest result is \\\n inconsistent.\")\n in\n return @@ List.rev rev_next_inc_proof\n in\n return\n (Page_unconfirmed {prev_cell; next_cell_opt; next_inc_proof}, None)\n | None, Found _ ->\n tzfail\n @@ dal_proof_error\n \"The page ID's slot is confirmed, but no page content and proof \\\n are provided.\"\n | Some _, Nearest _ ->\n tzfail\n @@ dal_proof_error\n \"The page ID's slot is not confirmed, but page content and \\\n proof are provided.\"\n\n let produce_proof dal_params page_id ~page_info ~get_history slots_hist =\n let open Lwt_result_syntax in\n let* proof_repr, page_data =\n produce_proof_repr dal_params page_id ~page_info ~get_history slots_hist\n in\n let*? serialized_proof = serialize_proof proof_repr in\n return (serialized_proof, page_data)\n\n (* Given a starting cell [snapshot] and a (final) [target], this function\n checks that the provided [inc_proof] encodes a minimal path from\n [snapshot] to [target]. *)\n let verify_inclusion_proof inc_proof ~src:snapshot ~dest:target =\n let assoc = List.map (fun c -> (hash c, c)) inc_proof in\n let path = List.split assoc |> fst in\n let deref =\n let open Map.Make (Pointer_hash) in\n let map = of_seq (List.to_seq assoc) in\n fun ptr -> find_opt ptr map\n in\n let snapshot_ptr = hash snapshot in\n let target_ptr = hash target in\n error_unless\n (Skip_list.valid_back_path\n ~equal_ptr:Pointer_hash.equal\n ~deref\n ~cell_ptr:snapshot_ptr\n ~target_ptr\n path)\n (dal_proof_error \"verify_proof_repr: invalid inclusion Dal proof.\")\n\n let verify_proof_repr dal_params page_id snapshot proof =\n let open Result_syntax in\n let Page.{slot_id; page_index = _} = page_id in\n match proof with\n | Page_confirmed {target_cell; page_data; page_proof; inc_proof} ->\n (* If the page is supposed to be confirmed, the last cell in\n [inc_proof] should store the slot of the page. *)\n let Header.{id; commitment} = Skip_list.content target_cell in\n let* () =\n error_when\n Compare.Int.(Header.compare_slot_id id Header.zero.id = 0)\n (dal_proof_error\n \"verify_proof_repr: cannot construct a confirmation page \\\n proof with 'zero' as target slot.\")\n in\n let* () =\n verify_inclusion_proof inc_proof ~src:snapshot ~dest:target_cell\n in\n (* We check that the page indeed belongs to the target slot at the\n given page index. *)\n let* () =\n check_page_proof dal_params page_proof page_data page_id commitment\n in\n (* If all checks succeed, we return the data/content of the page. *)\n return_some page_data\n | Page_unconfirmed {prev_cell; next_cell_opt; next_inc_proof} ->\n (* The page's slot is supposed to be unconfirmed. *)\n let ( < ) a b = Compare.Int.(Header.compare_slot_id a b < 0) in\n (* We retrieve the last cell of the inclusion proof to be able to\n call {!verify_inclusion_proof}. We also do some well-formedness on\n the shape of the inclusion proof (see the case [Page_unconfirmed]\n of type {!proof}). *)\n let* () =\n match next_cell_opt with\n | None ->\n let* () =\n error_unless\n (List.is_empty next_inc_proof)\n (dal_proof_error\n \"verify_proof_repr: invalid next_inc_proof\")\n in\n (* In case the inclusion proof has no elements, we check that:\n - the prev_cell slot's id is smaller than the unconfirmed slot's ID\n - the snapshot is equal to the [prev_cell] skip list.\n\n This way, and since the skip list is sorted wrt.\n {!compare_slot_id}, we are sure that the skip list whose head\n is [snapshot] = [prev_cell] cannot contain a slot whose ID is\n [slot_id]. *)\n error_unless\n ((Skip_list.content prev_cell).id < slot_id\n && equal_history snapshot prev_cell)\n (dal_proof_error \"verify_proof_repr: invalid next_inc_proof\")\n | Some next_cell ->\n (* In case the inclusion proof has at least one element,\n we check that:\n - the [prev_cell] slot's id is smaller than [slot_id]\n - the [next_cell] slot's id is greater than [slot_id]\n - the [next_cell] cell is a direct successor of the\n [prev_cell] cell.\n - the [next_cell] cell is a predecessor of [snapshot]\n\n Since the skip list is sorted wrt. {!compare_slot_id}, and\n if the call to {!verify_inclusion_proof} succeeds, we are\n sure that the skip list whose head is [snapshot] cannot\n contain a slot whose ID is [slot_id]. *)\n let* () =\n error_unless\n ((Skip_list.content prev_cell).id < slot_id\n && slot_id < (Skip_list.content next_cell).id\n &&\n let prev_cell_pointer =\n Skip_list.back_pointer next_cell 0\n in\n match prev_cell_pointer with\n | None -> false\n | Some prev_ptr ->\n Pointer_hash.equal prev_ptr (hash prev_cell))\n (dal_proof_error\n \"verify_proof_repr: invalid next_inc_proof\")\n in\n verify_inclusion_proof\n next_inc_proof\n ~src:snapshot\n ~dest:next_cell\n in\n return_none\n\n let verify_proof dal_params page_id snapshot serialized_proof =\n let open Result_syntax in\n let* proof_repr = deserialize_proof serialized_proof in\n verify_proof_repr dal_params page_id snapshot proof_repr\n\n module Internal_for_tests = struct\n let content = Skip_list.content\n\n let proof_statement_is serialized_proof expected =\n match deserialize_proof serialized_proof with\n | Error _ -> false\n | Ok proof -> (\n match (expected, proof) with\n | `Confirmed, Page_confirmed _ | `Unconfirmed, Page_unconfirmed _ ->\n true\n | _ -> false)\n end\n end\n\n include V1\nend\n" ;
} ;
{ name = "Dal_attestation_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Slot attestation representation for the data-availability layer.\n\n {1 Overview}\n\n For the data-availability layer, the layer 1 provides a list of\n slots at every level (see {!Dal_slot_repr}). Slots are not posted\n directly onto L1 blocks. Stakeholders, called attestors in this\n context, can commit on the availability of the data (via\n endorsements or attestation operations, see\n https://gitlab.com/tezos/tezos/-/issues/3115).\n\n The slot is uniformly split into shards. Each attestor commits,\n for every slot, on the availability of all shards they are assigned\n to.\n\n This module encapsulates the representation of this commitment\n that aims to be provided with endorsement operations. To avoid\n overloading the network, this representation should be compact. *)\n\ntype t\n\ntype attested_slots = t\n\n(** The shape of Dal attestation operations injected by delegates. *)\ntype operation = {\n attestor : Signature.Public_key_hash.t;\n (** The account who attests the availability of the slots. *)\n attestation : t;\n (** The bitset of slots that are attested to be available. *)\n level : Raw_level_repr.t;\n (** The level at which the operation is valid. It should be equal to the\n attested slot's published level plus the DAL attestation lag. *)\n}\n\nval encoding : t Data_encoding.t\n\n(** [empty] returns an empty [slot_attestation] which commits that\n every slot are unavailable. *)\nval empty : t\n\n(** [is_attested slot_attestation ~index] returns [true] if the\n [slot_attestation] commits that the slot at [index] is\n available. *)\nval is_attested : t -> Dal_slot_repr.Index.t -> bool\n\n(** [commit slot_attestation index] commits into [slot_attestation]\n that the [index] is available. *)\nval commit : t -> Dal_slot_repr.Index.t -> t\n\n(** [occupied_size_in_bits slot_attestation] returns the size in bits of an attestation. *)\nval occupied_size_in_bits : t -> int\n\n(** [expected_size_in_bits ~max_index] returns the expected size (in\n bits) of an attestation considering the maximum index for a slot is\n [max_index]. *)\nval expected_size_in_bits : max_index:Dal_slot_repr.Index.t -> int\n\n(** A shard_index aims to be a positive number. *)\ntype shard_index = int\n\nmodule Shard_map : Map.S with type key = shard_index\n\n(** This module is used to record the various data-availability\n attestations.\n\n For each attestor, a list of shards is associated. For each\n attested slot (see {!type:t}) we record that those shards were\n deemed available.\n\n This information will be used at the end of block finalisation to\n have the protocol declaring whether the slot is available. *)\nmodule Accountability : sig\n (** The data-structure used to record the shards-slots availability. *)\n type t\n\n (** DAL/FIXME https://gitlab.com/tezos/tezos/-/issues/3145\n\n Consider using the [Bounded] module. In particular, change the\n semantics of [is_slot_available] accordingly. *)\n\n (** [init ~length] initialises a new accountability data-structure\n with at most [length] slots and where for every slot, no shard is\n available. *)\n val init : length:int -> t\n\n (** [record_shards_availability t slots shards] records that for all\n slots declared available in [slots], shard indices in [shards]\n are available. It is the responsibility of the caller to ensure\n the shard indices are positive numbers. A negative shard index is\n ignored. *)\n val record_shards_availability : t -> attested_slots -> shard_index list -> t\n\n (** [is_slot_available t ~threshold ~number_of_shards slot] returns\n [true] if the number of shards recorded in [t] for the [slot] is\n above the [threshold] with respect to the total number of shards\n specified by [number_of_shards]. Returns [false] otherwise or if\n the [index] is out of the interval [0;length] where [length] is\n the value provided to the [init] function. *)\n val is_slot_available :\n t -> threshold:int -> number_of_shards:int -> Dal_slot_repr.Index.t -> bool\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(* DAL/FIXME https://gitlab.com/tezos/tezos/-/issues/3103\n\n This may be a bit heavy in practice. We could also assume that in\n practice, many bits in this bitfield will be set to one. Hence, we\n could consider a better encoding which is smaller in the optimistic\n case. For example:\n\n 1. When all the slots are attested, the encoding can be represented\n in one bit.\n\n 2. Otherwise, we can pack slots by [8]. Have a header of [slots/8]\n which is [1] if all the slots in this set are [1], [0]\n otherwise. For all pack with a bit set to [0], we give the explicit\n representation. Hence, if there are [256] slots, and [2] are not\n attested, this representation will be of size [32] bits + [16] bits\n = [48] bits which is better than [256] bits. *)\ntype t = Bitset.t\n\ntype attested_slots = t\n\ntype operation = {\n attestor : Signature.Public_key_hash.t;\n (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/4165\n Compute the endorser from the attested slots in [slot_attestation] below,\n or provide a field `min_endorser_slot : int / int32` *)\n attestation : t;\n level : Raw_level_repr.t;\n}\n\nlet encoding = Bitset.encoding\n\nlet empty = Bitset.empty\n\nlet is_attested t index =\n let open Dal_slot_repr.Index in\n match Bitset.mem t (to_int index) with\n | Ok b -> b\n | Error _ ->\n (* DAL/FIXME https://gitlab.com/tezos/tezos/-/issues/3104\n\n Should we do something here? *)\n false\n\nlet commit t index =\n let open Dal_slot_repr.Index in\n match Bitset.add t (to_int index) with\n | Ok t -> t\n | Error _ ->\n (* DAL/FIXME https://gitlab.com/tezos/tezos/-/issues/3104\n\n Should we do something here? *)\n t\n\nlet occupied_size_in_bits = Bitset.occupied_size_in_bits\n\nlet expected_size_in_bits ~max_index =\n (* We compute an encoding of the data-availability attestations\n which is a (tight) upper bound of what we expect. *)\n let open Bitset in\n let open Dal_slot_repr.Index in\n match add empty @@ to_int max_index with\n | Error _ -> (* Happens if max_index < 1 *) 0\n | Ok t -> occupied_size_in_bits t\n\ntype shard_index = int\n\nmodule Shard_map = Map.Make (struct\n type t = shard_index\n\n let compare = Compare.Int.compare\nend)\n\nmodule Accountability = struct\n (* DAL/FIXME https://gitlab.com/tezos/tezos/-/issues/3109\n\n Think hard about this data structure and whether it needs to be\n optimized.\n *)\n type t = Bitset.t list\n\n let init ~length =\n let l =\n List.init\n ~when_negative_length:\n \"Dal_attestation_repr.Accountability.init: length cannot be negative\"\n length\n (fun _ -> Bitset.empty)\n in\n match l with Error msg -> invalid_arg msg | Ok l -> l\n\n let record_slot_shard_availability bitset shards =\n List.fold_left\n (fun bitset shard ->\n Bitset.add bitset shard |> Result.value ~default:bitset)\n bitset\n shards\n\n let record_shards_availability shard_bitset_per_slot slots shards =\n List.mapi\n (fun slot bitset ->\n match Bitset.mem slots slot with\n | Error _ ->\n (* slot index is above the length provided at initialisation *)\n bitset\n | Ok slot_available ->\n if slot_available then record_slot_shard_availability bitset shards\n else bitset)\n shard_bitset_per_slot\n\n let is_slot_available shard_bitset_per_slot ~threshold ~number_of_shards index\n =\n match List.nth shard_bitset_per_slot (Dal_slot_repr.Index.to_int index) with\n | None -> false\n | Some bitset ->\n let acc = ref 0 in\n List.iter\n (fun x ->\n match Bitset.mem bitset x with\n | Error _ | Ok false -> ()\n | Ok true -> incr acc)\n Misc.(0 --> (number_of_shards - 1)) ;\n Compare.Int.(!acc >= threshold * number_of_shards / 100)\nend\n" ;
} ;
{ name = "Sc_rollup_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** The basic components of an optimistic rollup for smart-contracts. *)\n\n(**\n\n An optimistic rollup for smart-contracts is made of two main\n components:\n\n - a proof generating virtual machine (PVM), which provides the\n essential semantics for the rollup operations to be validated by\n the layer 1 in case of dispute about a commitment ;\n\n - a database which maintains the cemented operations of the rollup\n as well as the potentially-disputed operations.\n\n*)\n\n(** A smart rollup has an address starting with \"sr1\". *)\nmodule Address : sig\n include S.HASH\n\n (** [encoded_size] is the number of bytes needed to represent an address. *)\n val encoded_size : int\n\n val of_b58data : Base58.data -> t option\n\n (** [prefix] is the prefix of smart contract rollup addresses. *)\n val prefix : string\nend\n\nmodule Internal_for_tests : sig\n val originated_sc_rollup : Origination_nonce.t -> Address.t\nend\n\nmodule State_hash : sig\n include S.HASH\n\n (** [context_hash_to_state_hash ch] turns an (Irmin) context hash\n into a state hash. *)\n val context_hash_to_state_hash : Context_hash.t -> t\n\n (* Hackish way to disable hash_bytes and hash_string to force people to use\n context_hash_to_state_hash (without changing content of HASH.S) *)\n type unreachable = |\n\n val hash_bytes : unreachable -> t\n\n val hash_string : unreachable -> t\nend\n\n(** Number of ticks computed by a single commitment. This represents a claim\n about the state of the PVM, which can be disputed as part of a commitment\n dispute.\n\n See also {!Commitment_repr.}. *)\nmodule Number_of_ticks : sig\n include Bounded.S with type ocaml_type := int64\n\n val zero : t\nend\n\n(** A smart contract rollup is identified by its address. *)\ntype t = Address.t\n\nval encoding : t Data_encoding.t\n\nval rpc_arg : t RPC_arg.t\n\nval pp : Format.formatter -> t -> unit\n\n(** [in_memory_size sc_rollup] returns the number of bytes [sc_rollup]\n uses in RAM. *)\nval in_memory_size : t -> Cache_memory_helpers.sint\n\n(** A [Staker] is an implicit account, identified by its public key hash. *)\nmodule Staker :\n S.SIGNATURE_PUBLIC_KEY_HASH with type t = Signature.Public_key_hash.t\n\n(** The data model uses an index of these addresses. *)\nmodule Index : Storage_description.INDEX with type t = Address.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* Copyright (c) 2022 Marigold, <contact@marigold.dev> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule Address = struct\n let prefix = \"sr1\"\n\n let encoded_size = 36\n\n let decoded_prefix = \"\\006\\124\\117\" (* \"sr1(36)\" decoded from base 58. *)\n\n module H =\n Blake2B.Make\n (Base58)\n (struct\n let name = \"Smart_rollup_hash\"\n\n let title = \"A smart rollup address\"\n\n let b58check_prefix = decoded_prefix\n\n let size = Some 20\n end)\n\n include H\n\n let () = Base58.check_encoded_prefix b58check_encoding prefix encoded_size\n\n include Path_encoding.Make_hex (H)\n\n let of_b58data = function H.Data h -> Some h | _ -> None\nend\n\nmodule Internal_for_tests = struct\n let originated_sc_rollup nonce =\n let data =\n Data_encoding.Binary.to_bytes_exn Origination_nonce.encoding nonce\n in\n Address.hash_bytes [data]\nend\n\n(* 32 *)\nlet state_hash_prefix = \"\\017\\165\\235\\240\" (* srs1(54) *)\n\nmodule State_hash = struct\n let prefix = \"srs1\"\n\n let encoded_size = 54\n\n module H =\n Blake2B.Make\n (Base58)\n (struct\n let name = \"Smart_rollup_state_hash\"\n\n let title = \"The hash of the VM state of a smart rollup\"\n\n let b58check_prefix = state_hash_prefix\n\n (* defaults to 32 *)\n let size = None\n end)\n\n include H\n\n let () = Base58.check_encoded_prefix b58check_encoding prefix encoded_size\n\n include Path_encoding.Make_hex (H)\n\n let context_hash_to_state_hash =\n (* Both State_hash and Context_hash's hashes are supposed to have the\n same size. This top-level check enforces this invariant, in which case,\n no exception could be thrown by [of_bytes_exn] below *)\n let () = assert (Compare.Int.equal size Context_hash.size) in\n fun h -> of_bytes_exn @@ Context_hash.to_bytes h\n\n (* Hackish way to disable hash_bytes and hash_string to force people to use\n context_hash_to_state_hash (without changing content of HASH.S) *)\n type unreachable = |\n\n let hash_bytes = function (_ : unreachable) -> .\n\n let hash_string = function (_ : unreachable) -> .\nend\n\ntype t = Address.t\n\nlet description =\n \"A smart rollup is identified by a base58 address starting with \"\n ^ Address.prefix\n\nlet pp = Address.pp\n\nlet encoding =\n let open Data_encoding in\n def\n \"smart_rollup_address\"\n ~title:\"A smart rollup address\"\n ~description\n Address.encoding\n\nlet rpc_arg =\n RPC_arg.like\n Address.rpc_arg\n ~descr:\"A smart rollup address.\"\n \"smart_rollup_address\"\n\nlet in_memory_size (_ : t) =\n let open Cache_memory_helpers in\n h1w +! string_size_gen Address.size\n\nmodule Staker = Signature.Public_key_hash\n\nmodule Index = struct\n type t = Address.t\n\n let path_length = 1\n\n let to_path c l =\n let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in\n let (`Hex key) = Hex.of_bytes raw_key in\n key :: l\n\n let of_path = function\n | [key] ->\n Option.bind\n (Hex.to_bytes (`Hex key))\n (Data_encoding.Binary.of_bytes_opt encoding)\n | _ -> None\n\n let rpc_arg = rpc_arg\n\n let encoding = encoding\n\n let compare = Address.compare\nend\n\nmodule Number_of_ticks = struct\n include Bounded.Int64 (struct\n let min_value = 0L\n\n let max_value = Int64.max_int\n end)\n\n let zero =\n match of_value 0L with\n | Some zero -> zero\n | None -> assert false (* unreachable case, since [min_int = 0l] *)\nend\n" ;
} ;
{ name = "Sc_rollup_metadata_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Static rollup-related metadata for the PVMs. *)\n\n(** A metadata contains: *)\ntype t = {\n address : Sc_rollup_repr.Address.t; (** The rollup address. *)\n origination_level : Raw_level_repr.t;\n (** The origination level of the rollup. *)\n}\n\n(** Pretty-printer for metadatas *)\nval pp : Format.formatter -> t -> unit\n\n(** Metadatas equality *)\nval equal : t -> t -> bool\n\n(** Encoding for metadatas *)\nval encoding : t Data_encoding.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(* TODO: https://gitlab.com/tezos/tezos/-/issues/3898\n We also need dynamic metadatas. *)\n\ntype t = {\n address : Sc_rollup_repr.Address.t;\n origination_level : Raw_level_repr.t;\n}\n\nlet pp ppf {address; origination_level} =\n Format.fprintf\n ppf\n \"address: %a ; origination_level: %a\"\n Sc_rollup_repr.Address.pp\n address\n Raw_level_repr.pp\n origination_level\n\nlet equal {address; origination_level} metadata2 =\n Sc_rollup_repr.Address.equal address metadata2.address\n && Raw_level_repr.equal origination_level metadata2.origination_level\n\nlet encoding =\n let open Data_encoding in\n conv\n (fun {address; origination_level} -> (address, origination_level))\n (fun (address, origination_level) -> {address; origination_level})\n (obj2\n (req \"address\" Sc_rollup_repr.Address.encoding)\n (req \"origination_level\" Raw_level_repr.encoding))\n" ;
} ;
{ name = "Sc_rollup_tick_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module defines [Tick.t], an execution step counter for\n smart-contract rollups. *)\n\n(** A tick is a counter for the execution step of a smart-contract rollup. *)\ntype t\n\n(** The initial tick. *)\nval initial : t\n\n(** [next tick] returns the counter successor of [tick]. *)\nval next : t -> t\n\n(** [jump tick k] moves [tick] by [k] (possibly negative) steps.\n The move stops at [initial] when going back in time. *)\nval jump : t -> Z.t -> t\n\n(** [distance t1 t2] is the absolute value of the difference between [t1] and [t2]. *)\nval distance : t -> t -> Z.t\n\n(** [of_int x] returns [Some tick] for the rollup [x]-th execution\n step if [x] is non-negative. Returns [None] otherwise. *)\nval of_int : int -> t option\n\n(** [to_int tick] converts the [tick] into an integer. *)\nval to_int : t -> int option\n\n(** [of_number_of_ticks] converts from the bounded int type defined in\n the [Sc_rollup_repr] module. [Number_of_ticks] is used inside of\n commitments to limit the maximum possible storage requirement. It is\n bounded between one and [max_int] meaning that this can never return\n a negative number so an [option] isn't required. *)\nval of_number_of_ticks : Sc_rollup_repr.Number_of_ticks.t -> t\n\nval of_z : Z.t -> t\n\nval to_z : t -> Z.t\n\n(** [size_in_bytes tick] is the size in bytes of [tick]'s internal\n representation. This function is used by the gas model. *)\nval size_in_bytes : t -> int\n\nval encoding : t Data_encoding.t\n\nval pp : Format.formatter -> t -> unit\n\ninclude Compare.S with type t := t\n\nmodule Map : Map.S with type key = t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ninclude Z\n\nlet initial = zero\n\nlet next = succ\n\nlet jump tick z = max initial (add tick z)\n\nlet pp = pp_print\n\nlet encoding = Data_encoding.n\n\nlet distance tick1 tick2 = Z.abs (Z.sub tick1 tick2)\n\nlet of_int x = if Compare.Int.(x < 0) then None else Some (Z.of_int x)\n\nlet to_int x = if Z.fits_int x then Some (Z.to_int x) else None\n\nlet of_z x = x\n\nlet to_z x = x\n\nlet of_number_of_ticks x =\n Z.of_int64 (Sc_rollup_repr.Number_of_ticks.to_value x)\n\nlet ( <= ) = leq\n\nlet ( < ) = lt\n\nlet ( >= ) = geq\n\nlet ( > ) = gt\n\nlet ( = ) = equal\n\nlet ( <> ) x y = not (x = y)\n\nlet size_in_bytes tick =\n (* Same definition as in {!Michelson_v1_gas}. *)\n let bits = numbits tick in\n (7 + bits) / 8\n\nmodule Map = Map.Make (Z)\n" ;
} ;
{ name = "Sc_rollup_inbox_message_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module exposes a type {!t} that represents inbox messages. Inbox\n messages are produced by the Layer 1 protocol and are encoded using the\n {!serialize} function, before being added to a smart-contract rollup's inbox.\n\n They are part of the [Rollup Management Protocol] that defines the\n communication protocol for exchanging messages between Layer 1 and Layer 2\n for a smart-contract rollup.\n\n There are two types of inbox messages: external and internal.\n\n Internal messages originate from Layer 1 smart-contract and consist of:\n - [payload] the parameters passed to the smart-contract rollup.\n - [sender] the Layer 1 contract caller.\n - [source] the public key hash used for originating the transaction.\n\n External messages originate from the [Sc_rollup_add_messages]\n manager-operation and consists of strings. The Layer 2 node is responsible\n for decoding and interpreting these messages.\n *)\n\n(** [internal_inbox_message] represent an internal message in a inbox (L1 ->\n L2). This is not inline so it can easily be used by\n {!Sc_rollup_costs.cost_serialize_internal_inbox_message}. *)\ntype internal_inbox_message =\n | Transfer of {\n payload : Script_repr.expr;\n (** A Micheline value containing the parameters passed to the rollup. *)\n sender : Contract_hash.t;\n (** The contract hash of an Layer 1 originated contract sending a message\n to the rollup. *)\n source : Signature.public_key_hash;\n (** The implicit account that originated the transaction. *)\n destination : Sc_rollup_repr.Address.t;\n (** The destination, as a rollup address, for the message. *)\n }\n | Start_of_level\n (** Internal message put at the beginning of each inbox's level. *)\n | End_of_level (** Internal message put at the end of each inbox's level. *)\n | Info_per_level of {\n predecessor_timestamp : Time.t;\n (** Timestamp of the predecessor block where this message is\n pushed. *)\n predecessor : Block_hash.t;\n (** Predecessor of the block this message is pushed. *)\n }\n\n(** A type representing messages from Layer 1 to Layer 2. Internal ones are\n originated from Layer 1 smart-contracts and external ones are messages from\n an external manager operation. *)\ntype t = Internal of internal_inbox_message | External of string\n\ntype serialized = private string\n\n(** Encoding for messages from Layer 1 to Layer 2 *)\nval encoding : t Data_encoding.t\n\n(** [serialize msg] encodes the inbox message [msg] in binary format. *)\nval serialize : t -> serialized tzresult\n\n(** [deserialize bs] decodes [bs] as an inbox_message [t]. *)\nval deserialize : serialized -> t tzresult\n\nval unsafe_of_string : string -> serialized\n\nval unsafe_to_string : serialized -> string\n\nmodule Hash : S.HASH\n\n(** [hash_serialized_message payload] is the hash of [payload]. It is used by\n {!Sc_rollup_inbox_merkelized_payload_hashes_repr.t}. *)\nval hash_serialized_message : serialized -> Hash.t\n\n(** {!serialized} representation of [Internal [Start_of_level]]. *)\nval start_of_level_serialized : serialized\n\n(** {!serialized} representation of [Internal [End_of_level]]. *)\nval end_of_level_serialized : serialized\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error +=\n | (* `Permanent *) Error_encode_inbox_message\n | (* `Permanent *) Error_decode_inbox_message\n\nlet () =\n let open Data_encoding in\n let msg =\n \"Failed to encode a rollup management protocol inbox message value\"\n in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_inbox_message_encoding\"\n ~title:msg\n ~pp:(fun fmt () -> Format.fprintf fmt \"%s\" msg)\n ~description:msg\n unit\n (function Error_encode_inbox_message -> Some () | _ -> None)\n (fun () -> Error_encode_inbox_message) ;\n let msg =\n \"Failed to decode a smart rollup management protocol inbox message value\"\n in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_inbox_message_decoding\"\n ~title:msg\n ~pp:(fun fmt () -> Format.fprintf fmt \"%s\" msg)\n ~description:msg\n unit\n (function Error_decode_inbox_message -> Some () | _ -> None)\n (fun () -> Error_decode_inbox_message)\n\ntype internal_inbox_message =\n | Transfer of {\n payload : Script_repr.expr;\n sender : Contract_hash.t;\n source : Signature.public_key_hash;\n destination : Sc_rollup_repr.Address.t;\n }\n | Start_of_level\n | End_of_level\n | Info_per_level of {\n predecessor_timestamp : Time.t;\n predecessor : Block_hash.t;\n }\n\nlet internal_inbox_message_encoding =\n let open Data_encoding in\n let kind name = req \"internal_inbox_message_kind\" (constant name) in\n union\n [\n case\n (Tag 0)\n ~title:\"Transfer\"\n (obj5\n (kind \"transfer\")\n (req \"payload\" Script_repr.expr_encoding)\n (req \"sender\" Contract_hash.encoding)\n (req \"source\" Signature.Public_key_hash.encoding)\n (req \"destination\" Sc_rollup_repr.Address.encoding))\n (function\n | Transfer {payload; sender; source; destination} ->\n Some ((), payload, sender, source, destination)\n | _ -> None)\n (fun ((), payload, sender, source, destination) ->\n Transfer {payload; sender; source; destination});\n case\n (Tag 1)\n ~title:\"Start_of_level\"\n (obj1 (kind \"start_of_level\"))\n (function Start_of_level -> Some () | _ -> None)\n (fun () -> Start_of_level);\n case\n (Tag 2)\n ~title:\"End_of_level\"\n (obj1 (kind \"end_of_level\"))\n (function End_of_level -> Some () | _ -> None)\n (fun () -> End_of_level);\n case\n (Tag 3)\n ~title:\"Info_per_level\"\n (obj3\n (kind \"info_per_level\")\n (req \"predecessor_timestamp\" Time.encoding)\n (req \"predecessor\" Block_hash.encoding))\n (function\n | Info_per_level {predecessor_timestamp; predecessor} ->\n Some ((), predecessor_timestamp, predecessor)\n | _ -> None)\n (fun ((), predecessor_timestamp, predecessor) ->\n Info_per_level {predecessor_timestamp; predecessor});\n ]\n\ntype t = Internal of internal_inbox_message | External of string\n\nlet encoding =\n let open Data_encoding in\n check_size\n Constants_repr.sc_rollup_message_size_limit\n (union\n [\n case\n (Tag 0)\n ~title:\"Internal\"\n internal_inbox_message_encoding\n (function\n | Internal internal_message -> Some internal_message\n | External _ -> None)\n (fun internal_message -> Internal internal_message);\n case\n (Tag 1)\n ~title:\"External\"\n Variable.(string Hex)\n (function External msg -> Some msg | Internal _ -> None)\n (fun msg -> External msg);\n ])\n\ntype serialized = string\n\nlet serialize msg =\n let open Result_syntax in\n match Data_encoding.Binary.to_string_opt encoding msg with\n | None -> tzfail Error_encode_inbox_message\n | Some str -> return str\n\nlet deserialize s =\n let open Result_syntax in\n match Data_encoding.Binary.of_string_opt encoding s with\n | None -> tzfail Error_decode_inbox_message\n | Some msg -> return msg\n\nlet unsafe_of_string s = s\n\nlet unsafe_to_string s = s\n\n(* 32 *)\nlet hash_prefix = \"\\003\\255\\138\\145\\170\" (* srib3(55) *)\n\nmodule Hash = struct\n let prefix = \"srib3\"\n\n let encoded_size = 55\n\n module H =\n Blake2B.Make\n (Base58)\n (struct\n let name = \"Smart_rollup_serialized_message_hash\"\n\n let title =\n \"The hash of a serialized message of the smart rollup inbox.\"\n\n let b58check_prefix = hash_prefix\n\n (* defaults to 32 *)\n let size = None\n end)\n\n include H\n\n let () = Base58.check_encoded_prefix b58check_encoding prefix encoded_size\nend\n\nlet hash_serialized_message (payload : serialized) =\n Hash.hash_string [(payload :> string)]\n\nlet start_of_level_serialized =\n (* If [Start_of_level] cannot be serialized, this will be detected at\n compilation time as we are defining a top-level value. *)\n Data_encoding.Binary.to_string_exn encoding (Internal Start_of_level)\n\nlet end_of_level_serialized =\n (* If [End_of_level] cannot be serialized, this will be detected at\n compilation time as we are defining a top-level value. *)\n Data_encoding.Binary.to_string_exn encoding (Internal End_of_level)\n" ;
} ;
{ name = "Sc_rollup_inbox_merkelized_payload_hashes_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error += Merkelized_payload_hashes_proof_error of string\n\nmodule Hash : S.HASH\n\n(** A type representing the head of a merkelized list of\n {!Sc_rollup_inbox_message_repr.serialized} message. It contains the hash of\n the payload and the index on the list. *)\ntype t\n\nval encoding : t Data_encoding.t\n\ntype merkelized_and_payload = {\n merkelized : t;\n payload : Sc_rollup_inbox_message_repr.serialized;\n}\n\n(** A [History.t] is a lookup table of {!merkelized_and_payload}s. Payloads are\n indexed by their hash {!Hash.t}. This history is needed in order to produce\n {!proof}.\n\n A subtlety of this [history] type is that it is customizable depending on\n how much of the inbox history you actually want to remember, using the\n [capacity] parameter. In the L1 we use this with [capacity] set to zero,\n which makes it immediately forget an old level as soon as we move to the\n next. By contrast, the rollup node uses a history that is sufficiently large\n to be able to take part in all potential refutation games occurring during\n the challenge period. *)\nmodule History : sig\n include\n Bounded_history_repr.S\n with type key = Hash.t\n and type value = merkelized_and_payload\n\n val no_history : t\nend\n\n(** [hash merkelized] is the hash of [merkelized]. It is used as key to remember\n a merkelized payload hash in an {!History.t}. *)\nval hash : t -> Hash.t\n\n(** [remember history merkelized payload] remembers the [{merkelized; payload}]\n in [history] with key [hash merkelized]. *)\nval remember :\n History.t ->\n t ->\n Sc_rollup_inbox_message_repr.serialized ->\n History.t tzresult\n\n(** [genesis history payload] is the initial merkelized payload hashes with\n index 0. It is remembered in [history] using [remember]. *)\nval genesis :\n History.t ->\n Sc_rollup_inbox_message_repr.serialized ->\n (History.t * t) tzresult\n\n(** [add_payload history merkelized payload] creates a new {!t} with [payload]\n and [merkelized] as ancestor (i.e. [index = succ (get_index\n merkelized)]). [merkelized] is remembered in [history] with [remember]. *)\nval add_payload :\n History.t ->\n t ->\n Sc_rollup_inbox_message_repr.serialized ->\n (History.t * t) tzresult\n\nval equal : t -> t -> bool\n\nval pp : Format.formatter -> t -> unit\n\n(** [get_payload_hash merkelized] returns the\n {!Sc_rollup_inbox_message_repr.serialized} payload's hash of\n [merkelized]. *)\nval get_payload_hash : t -> Sc_rollup_inbox_message_repr.Hash.t\n\n(** [get_index merkelized] returns the index of [merkelized]. *)\nval get_index : t -> Z.t\n\n(** Given two t [(a, b)] and a {!Sc_rollup_inbox_message_repr.serialized}\n [payload], a [proof] guarantees that [payload] hash is equal to [a] and that\n [a] is an ancestor of [b]; i.e. [get_index a < get_index b]. *)\ntype proof = private t list\n\nval pp_proof : Format.formatter -> proof -> unit\n\nval proof_encoding : proof Data_encoding.t\n\n(** [produce_proof history ~index into_] returns a {!merkelized_and_payload}\n with index [index] and a proof that it is an ancestor of [into_]. Returns\n [None] if no merkelized payload with [index] is found (either in the\n [history] or [index] is not inferior to [get_index into_]). *)\nval produce_proof :\n History.t -> index:Z.t -> t -> (merkelized_and_payload * proof) option\n\n(** [verify_proof proof] returns [(a, b)] where [proof] validates that [a] is an\n ancestor of [b]. Fails when [proof] is not a valid inclusion proof. *)\nval verify_proof : proof -> (t * t) tzresult\n\nmodule Internal_for_tests : sig\n (** [find_predecessor_payload history ~index latest_merkelized] looks for the\n {!t} with [index] that is an ancestor of [latest_merkelized]. *)\n val find_predecessor_payload : History.t -> index:Z.t -> t -> t option\n\n val make_proof : t list -> proof\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error += (* `Permanent *) Merkelized_payload_hashes_proof_error of string\n\nlet () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"internal.smart_rollup_merklized_payload_hashes_proof\"\n ~title:\n \"Internal error: error occurred during proof production or validation\"\n ~description:\"A merkelized payload hashes proof error.\"\n ~pp:(fun ppf e -> Format.fprintf ppf \"Proof error: %s\" e)\n (obj1 (req \"error\" (string Plain)))\n (function Merkelized_payload_hashes_proof_error e -> Some e | _ -> None)\n (fun e -> Merkelized_payload_hashes_proof_error e)\n\nmodule Skip_list_parameters = struct\n let basis = 4\nend\n\nmodule Skip_list = Skip_list_repr.Make (Skip_list_parameters)\n\n(* 32 *)\nlet hash_prefix = \"\\003\\255\\138\\145\\140\" (* srib2(55) *)\n\nmodule Hash = struct\n let prefix = \"srib2\"\n\n let encoded_size = 55\n\n module H =\n Blake2B.Make\n (Base58)\n (struct\n let name = \"Smart_rollup_merkelized_payload_hashes_hash\"\n\n let title =\n \"The merkelized payload hashes' hash of the smart rollup inbox\"\n\n let b58check_prefix = hash_prefix\n\n (* defaults to 32 *)\n let size = None\n end)\n\n include H\n\n let () = Base58.check_encoded_prefix b58check_encoding prefix encoded_size\nend\n\ntype t = (Sc_rollup_inbox_message_repr.Hash.t, Hash.t) Skip_list.cell\n\nlet equal = Skip_list.equal Hash.equal Sc_rollup_inbox_message_repr.Hash.equal\n\nlet hash merkelized =\n let payload_hash = Skip_list.content merkelized in\n let back_pointers_hashes = Skip_list.back_pointers merkelized in\n Sc_rollup_inbox_message_repr.Hash.to_bytes payload_hash\n :: List.map Hash.to_bytes back_pointers_hashes\n |> Hash.hash_bytes\n\nlet pp =\n Skip_list.pp ~pp_content:Sc_rollup_inbox_message_repr.Hash.pp ~pp_ptr:Hash.pp\n\nlet encoding =\n Skip_list.encoding Hash.encoding Sc_rollup_inbox_message_repr.Hash.encoding\n\ntype merkelized_and_payload = {\n merkelized : t;\n payload : Sc_rollup_inbox_message_repr.serialized;\n}\n\nlet equal_merkelized_and_payload {merkelized; payload} mp2 =\n equal merkelized mp2.merkelized\n && String.equal (payload :> string) (mp2.payload :> string)\n\nlet pp_merkelized_and_payload fmt {merkelized; payload} =\n Format.fprintf\n fmt\n \"@[<hv 2>merkelized:@,%a@,payload: %a@]\"\n pp\n merkelized\n Format.pp_print_string\n (payload :> string)\n\nlet merkelized_and_payload_encoding =\n let open Data_encoding in\n conv\n (fun {merkelized; payload} -> (merkelized, (payload :> string)))\n (fun (merkelized, payload) ->\n {\n merkelized;\n payload = Sc_rollup_inbox_message_repr.unsafe_of_string payload;\n })\n (merge_objs encoding (obj1 (req \"payload\" (string Hex))))\n\nmodule History = struct\n include\n Bounded_history_repr.Make\n (struct\n let name = \"Smart_rollup_level_inbox_history\"\n end)\n (Hash)\n (struct\n type nonrec t = merkelized_and_payload\n\n let pp = pp_merkelized_and_payload\n\n let equal = equal_merkelized_and_payload\n\n let encoding = merkelized_and_payload_encoding\n end)\n\n let no_history = empty ~capacity:0L\nend\n\nlet remember history merkelized payload =\n let prev_cell_ptr = hash merkelized in\n History.remember prev_cell_ptr {merkelized; payload} history\n\nlet genesis history payload =\n let open Result_syntax in\n let payload_hash =\n Sc_rollup_inbox_message_repr.hash_serialized_message payload\n in\n let merkelized = Skip_list.genesis payload_hash in\n let+ history = remember history merkelized payload in\n (history, merkelized)\n\nlet add_payload history prev_merkelized payload =\n let open Result_syntax in\n let prev_merkelized_ptr = hash prev_merkelized in\n let merkelized =\n Skip_list.next\n ~prev_cell:prev_merkelized\n ~prev_cell_ptr:prev_merkelized_ptr\n (Sc_rollup_inbox_message_repr.hash_serialized_message payload)\n in\n let* history = remember history merkelized payload in\n return (history, merkelized)\n\nlet get_payload_hash = Skip_list.content\n\nlet get_index = Skip_list.index\n\ntype proof = t list\n\nlet pp_proof = Format.pp_print_list pp\n\nlet proof_encoding = Data_encoding.list encoding\n\nlet produce_proof history ~index merkelized =\n let open Option_syntax in\n let deref ptr =\n let* {merkelized; payload = _} = History.find ptr history in\n return merkelized\n in\n let current_ptr = hash merkelized in\n let lift_ptr =\n let rec aux acc = function\n | [] -> None\n | [last_ptr] ->\n let+ ({merkelized; _} as merkelized_and_payload) =\n History.find last_ptr history\n in\n (merkelized_and_payload, List.rev (merkelized :: acc))\n | ptr :: rest ->\n let* merkelized = deref ptr in\n aux (merkelized :: acc) rest\n in\n aux []\n in\n let* ptr_path =\n Skip_list.back_path ~deref ~cell_ptr:current_ptr ~target_index:index\n in\n lift_ptr ptr_path\n\nlet verify_proof inclusion_proof =\n let open Result_syntax in\n let* cell =\n match inclusion_proof with\n | cell :: _ -> ok cell\n | [] ->\n error (Merkelized_payload_hashes_proof_error \"inclusion proof is empty\")\n in\n let rec aux (hash_map, ptr_list) = function\n | [] ->\n error (Merkelized_payload_hashes_proof_error \"inclusion proof is empty\")\n | [target] ->\n let target_ptr = hash target in\n let hash_map = Hash.Map.add target_ptr target hash_map in\n let ptr_list = List.rev (target_ptr :: ptr_list) in\n ok (hash_map, ptr_list, target, target_ptr)\n | merkelized :: tail ->\n let ptr = hash merkelized in\n aux (Hash.Map.add ptr merkelized hash_map, ptr :: ptr_list) tail\n in\n let* hash_map, ptr_list, target, target_ptr =\n aux (Hash.Map.empty, []) inclusion_proof\n in\n let deref ptr = Hash.Map.find ptr hash_map in\n let cell_ptr = hash cell in\n let* () =\n error_unless\n (Skip_list.valid_back_path\n ~equal_ptr:Hash.equal\n ~deref\n ~cell_ptr\n ~target_ptr\n ptr_list)\n (Merkelized_payload_hashes_proof_error \"invalid inclusion proof\")\n in\n return (target, cell)\n\nmodule Internal_for_tests = struct\n let find_predecessor_payload payloads_history ~index payloads =\n let open Option_syntax in\n let deref ptr =\n let* {merkelized; _} = History.find ptr payloads_history in\n return merkelized\n in\n let cell_ptr = hash payloads in\n Skip_list.find ~deref ~cell_ptr ~target_index:index\n\n let make_proof proof = proof\nend\n" ;
} ;
{ name = "Sc_rollup_outbox_message_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module defines a data type {!t} that represents messages from Layer 2\n to Layer 1.\n\n They are part of the [Rollup Management Protocol] that defines the\n communication protocol for exchanging messages between Layer 1 and Layer 2\n for smart-contract rollups.\n\n An outbox-message consists of a sequence of transactions to L1\n smart-contract accounts. All transactions contained in a message are\n intended to be executed as a batch.\n *)\n\n(** A transaction from L2 to L1. *)\ntype transaction = {\n unparsed_parameters : Script_repr.expr; (** The payload. *)\n destination : Contract_hash.t; (** The recipient contract. *)\n entrypoint : Entrypoint_repr.t; (** Entrypoint of the destination. *)\n}\n\n(** A type representing messages from Layer 2 to Layer 1. *)\ntype t = Atomic_transaction_batch of {transactions : transaction list}\n\nval encoding : t Data_encoding.t\n\nval pp : Format.formatter -> t -> unit\n\ntype serialized = private string\n\n(** [deserialize ctxt bs] decodes an outbox message value from the\n given data [bs]. The function involves parsing Micheline expressions to\n typed values. *)\nval deserialize : serialized -> t tzresult\n\n(** [serialize msg] serializes the given outbox message [msg]. *)\nval serialize : t -> serialized tzresult\n\n(** [unsafe_of_string s] builds a serialized value out of a string.\n You must understand the invariants of [serialized] to do so. *)\nval unsafe_of_string : string -> serialized\n\n(** [unsafe_to_string s] builds a string out of a serialized value.\n You must understand the invariants of [serialized] to manipulate\n the resulting string. *)\nval unsafe_to_string : serialized -> string\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error +=\n | (* `Permanent *) Error_encode_outbox_message\n | (* `Permanent *) Error_decode_outbox_message\n\nlet () =\n let open Data_encoding in\n let msg =\n \"Failed to encode a rollup management protocol outbox message value\"\n in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_outbox_message_repr.error_encoding_outbox_message\"\n ~title:msg\n ~pp:(fun fmt () -> Format.fprintf fmt \"%s\" msg)\n ~description:msg\n unit\n (function Error_encode_outbox_message -> Some () | _ -> None)\n (fun () -> Error_encode_outbox_message) ;\n let msg =\n \"Failed to decode a rollup management protocol outbox message value\"\n in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_outbox_message_repr.error_decoding_outbox_message\"\n ~title:msg\n ~pp:(fun fmt () -> Format.fprintf fmt \"%s\" msg)\n ~description:msg\n unit\n (function Error_decode_outbox_message -> Some () | _ -> None)\n (fun () -> Error_decode_outbox_message)\n\ntype transaction = {\n unparsed_parameters : Script_repr.expr; (** The payload. *)\n destination : Contract_hash.t; (** The recipient contract. *)\n entrypoint : Entrypoint_repr.t; (** Entrypoint of the destination. *)\n}\n\ntype t = Atomic_transaction_batch of {transactions : transaction list}\n\nlet transaction_encoding =\n let open Data_encoding in\n conv\n (fun {unparsed_parameters; destination; entrypoint} ->\n (unparsed_parameters, destination, entrypoint))\n (fun (unparsed_parameters, destination, entrypoint) ->\n {unparsed_parameters; destination; entrypoint})\n @@ obj3\n (req \"parameters\" Script_repr.expr_encoding)\n (req \"destination\" Contract_repr.originated_encoding)\n Entrypoint_repr.(dft \"entrypoint\" simple_encoding default)\n\nlet encoding =\n let open Data_encoding in\n (* We use a union encoding in order to guarantee backwards compatibility\n when outbox messages are extended with more constructors.\n\n Each new constructor must be added with an increased tag number.\n *)\n check_size\n Constants_repr.sc_rollup_message_size_limit\n (union\n [\n case\n (Tag 0)\n ~title:\"Atomic_transaction_batch\"\n (obj1 (req \"transactions\" (list transaction_encoding)))\n (fun (Atomic_transaction_batch {transactions}) -> Some transactions)\n (fun transactions -> Atomic_transaction_batch {transactions});\n ])\n\nlet pp_transaction fmt {destination; entrypoint; unparsed_parameters} =\n let json =\n Data_encoding.Json.construct Script_repr.expr_encoding unparsed_parameters\n in\n Format.fprintf\n fmt\n \"@[%a@;%a@;%a@]\"\n Contract_hash.pp\n destination\n Entrypoint_repr.pp\n entrypoint\n Data_encoding.Json.pp\n json\n\nlet pp fmt (Atomic_transaction_batch {transactions}) =\n Format.pp_print_list\n ~pp_sep:Format.pp_print_space\n pp_transaction\n fmt\n transactions\n\ntype serialized = string\n\nlet deserialize data =\n let open Result_syntax in\n match Data_encoding.Binary.of_string_opt encoding data with\n | Some x -> return x\n | None -> tzfail Error_decode_outbox_message\n\nlet serialize outbox_message =\n let open Result_syntax in\n match Data_encoding.Binary.to_string_opt encoding outbox_message with\n | Some str -> return str\n | None -> tzfail Error_encode_outbox_message\n\nlet unsafe_of_string s = s\n\nlet unsafe_to_string s = s\n" ;
} ;
{ name = "Sc_rollup_dissection_chunk_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Sc_rollup_repr\n\n(** A dissection chunk is made of an optional state hash, and a tick count. *)\ntype t = {state_hash : State_hash.t option; tick : Sc_rollup_tick_repr.t}\n\nval equal : t -> t -> bool\n\nval pp : Format.formatter -> t -> unit\n\nval encoding : t Data_encoding.t\n\nval default_check_sections_number :\n default_number_of_sections:int ->\n number_of_sections:int ->\n dist:Z.t ->\n unit tzresult\n\n(** We check firstly that [dissection] is the correct length. It must\n be [default_number_of_sections] values long, unless the distance\n between [start_tick] and [stop_tick] is too small to make this\n possible, in which case it should be as long as possible. (If the\n distance is one we fail immediately as there is no possible legal\n dissection).\n\n Then we check that [dissection] starts at the correct tick and\n state (specified by [start_chunk]), and that it ends at\n [stop_chunk], at the correct tick and with a different state to\n the current dissection.\n\n Finally, we check that [dissection] is well formed: it has\n correctly ordered the ticks, and it begins with a real hash of the\n form [Some s] not a [None] state. Note that we have to allow the\n possibility of multiple [None] states because the restrictions on\n dissection shape (which are necessary to prevent a 'linear-time\n game' attack) will mean that sometimes the honest play is a\n dissection with multiple [None] states. *)\nval default_check :\n section_maximum_size:Z.t ->\n check_sections_number:\n (default_number_of_sections:int ->\n number_of_sections:int ->\n dist:Z.t ->\n unit tzresult) ->\n default_number_of_sections:int ->\n start_chunk:t ->\n stop_chunk:t ->\n t list ->\n unit tzresult\n\ntype error +=\n | Dissection_number_of_sections_mismatch of {expected : Z.t; given : Z.t}\n (** There are more or less than the expected number of sections in the\n given dissection. *)\n | Dissection_invalid_number_of_sections of Z.t\n (** There are less than two sections in the given dissection, which is\n not valid. *)\n | Dissection_start_hash_mismatch of {\n expected : Sc_rollup_repr.State_hash.t option;\n given : Sc_rollup_repr.State_hash.t option;\n }\n (** The given start hash in a dissection is [None] or doesn't match the\n expected one.*)\n | Dissection_stop_hash_mismatch of Sc_rollup_repr.State_hash.t option\n (** The given stop state hash in a dissection should not match the last\n hash of the section being refuted. *)\n | Dissection_edge_ticks_mismatch of {\n dissection_start_tick : Sc_rollup_tick_repr.t;\n dissection_stop_tick : Sc_rollup_tick_repr.t;\n chunk_start_tick : Sc_rollup_tick_repr.t;\n chunk_stop_tick : Sc_rollup_tick_repr.t;\n }\n (** The given dissection's edge ticks don't match the edge ticks of the\n section being refuted. *)\n | Dissection_ticks_not_increasing\n (** Invalid provided dissection because ticks are not increasing between\n two successive sections. *)\n | Dissection_invalid_distribution of Z.t\n (** Invalid provided dissection because ticks split is not well balanced\n across sections *)\n | Dissection_invalid_successive_states_shape\n (** A dissection cannot have a section with no state hash after another\n section with some state hash. *)\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Sc_rollup_repr\n\ntype t = {state_hash : State_hash.t option; tick : Sc_rollup_tick_repr.t}\n\nlet equal {state_hash; tick} chunk2 =\n Option.equal State_hash.equal state_hash chunk2.state_hash\n && Sc_rollup_tick_repr.equal tick chunk2.tick\n\nlet encoding =\n let open Data_encoding in\n conv\n (fun {state_hash; tick} -> (state_hash, tick))\n (fun (state_hash, tick) -> {state_hash; tick})\n (obj2\n (opt \"state\" State_hash.encoding)\n (req \"tick\" Sc_rollup_tick_repr.encoding))\n\ntype error +=\n | (* `Temporary *)\n Dissection_number_of_sections_mismatch of {\n expected : Z.t;\n given : Z.t;\n }\n | (* `Permanent *) Dissection_invalid_number_of_sections of Z.t\n | (* `Temporary *)\n Dissection_start_hash_mismatch of {\n expected : Sc_rollup_repr.State_hash.t option;\n given : Sc_rollup_repr.State_hash.t option;\n }\n | (* `Temporary *)\n Dissection_stop_hash_mismatch of\n Sc_rollup_repr.State_hash.t option\n | (* `Temporary *)\n Dissection_edge_ticks_mismatch of {\n dissection_start_tick : Sc_rollup_tick_repr.t;\n dissection_stop_tick : Sc_rollup_tick_repr.t;\n chunk_start_tick : Sc_rollup_tick_repr.t;\n chunk_stop_tick : Sc_rollup_tick_repr.t;\n }\n | (* `Permanent *) Dissection_ticks_not_increasing\n | (* `Permanent *) Dissection_invalid_distribution of Z.t\n | (* `Permanent *) Dissection_invalid_successive_states_shape\n\nlet pp_state_hash =\n let open Format in\n pp_print_option ~none:(fun ppf () -> fprintf ppf \"None\") State_hash.pp\n\nlet pp_hash_opt fmt = function\n | None -> Format.fprintf fmt \"None\"\n | Some x -> Sc_rollup_repr.State_hash.pp fmt x\n\nlet pp ppf {state_hash; tick} =\n let open Format in\n fprintf\n ppf\n \"State hash:%a@ Tick: %a\"\n pp_state_hash\n state_hash\n Sc_rollup_tick_repr.pp\n tick\n\nlet default_check_sections_number ~default_number_of_sections\n ~number_of_sections ~dist =\n let open Result_syntax in\n let number_of_sections = Z.of_int number_of_sections in\n let default_number_of_sections = Z.of_int default_number_of_sections in\n let should_be_equal_to expected =\n Dissection_number_of_sections_mismatch\n {expected; given = number_of_sections}\n in\n if Compare.Z.(default_number_of_sections <= dist) then\n error_unless\n Compare.Z.(number_of_sections = default_number_of_sections)\n (should_be_equal_to default_number_of_sections)\n else if Compare.Z.(dist > Z.one) then\n error_unless Compare.Z.(number_of_sections = dist) (should_be_equal_to dist)\n else tzfail (Dissection_invalid_number_of_sections number_of_sections)\n\nlet default_check ~section_maximum_size ~check_sections_number\n ~default_number_of_sections ~start_chunk ~stop_chunk dissection =\n let open Result_syntax in\n let number_of_sections = Compare.Int.max 0 (List.length dissection - 1) in\n let dist = Sc_rollup_tick_repr.distance start_chunk.tick stop_chunk.tick in\n let* () =\n check_sections_number ~default_number_of_sections ~number_of_sections ~dist\n in\n let* () =\n match (List.hd dissection, List.last_opt dissection) with\n | Some {state_hash = a; tick = a_tick}, Some {state_hash = b; tick = b_tick}\n ->\n let* () =\n error_unless\n (Option.equal State_hash.equal a start_chunk.state_hash\n && not (Option.is_none a))\n (Dissection_start_hash_mismatch\n {expected = start_chunk.state_hash; given = a})\n in\n let* () =\n error_unless\n (not (Option.equal State_hash.equal b stop_chunk.state_hash))\n ((* If the [b] state is equal to [stop_chunk], that means we\n agree on the after state of the section. But, we're trying\n to dispute it, it doesn't make sense. *)\n Dissection_stop_hash_mismatch\n stop_chunk.state_hash)\n in\n Sc_rollup_tick_repr.(\n error_unless\n (a_tick = start_chunk.tick && b_tick = stop_chunk.tick)\n (Dissection_edge_ticks_mismatch\n {\n dissection_start_tick = a_tick;\n dissection_stop_tick = b_tick;\n chunk_start_tick = start_chunk.tick;\n chunk_stop_tick = stop_chunk.tick;\n }))\n | _ ->\n (* This case is probably already handled by the\n [Dissection_invalid_number_of_sections] returned above *)\n tzfail\n (Dissection_invalid_number_of_sections (Z.of_int number_of_sections))\n in\n let rec traverse states =\n match states with\n | {state_hash = None; _} :: {state_hash = Some _; _} :: _ ->\n tzfail Dissection_invalid_successive_states_shape\n | {tick; _} :: ({tick = next_tick; state_hash = _} as next) :: others ->\n if Sc_rollup_tick_repr.(tick < next_tick) then\n let incr = Sc_rollup_tick_repr.distance tick next_tick in\n if Z.(leq incr section_maximum_size) then traverse (next :: others)\n else tzfail (Dissection_invalid_distribution section_maximum_size)\n else tzfail Dissection_ticks_not_increasing\n | _ -> return ()\n in\n traverse dissection\n\nlet () =\n let description = \"Mismatch in the number of sections in the dissection\" in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_dissection_number_of_sections_mismatch\"\n ~title:description\n ~description\n ~pp:(fun ppf (expected, given) ->\n Format.fprintf\n ppf\n \"The number of sections must be equal to %a instead of %a\"\n Z.pp_print\n expected\n Z.pp_print\n given)\n Data_encoding.(obj2 (req \"expected\" n) (req \"given\" n))\n (function\n | Dissection_number_of_sections_mismatch {expected; given} ->\n Some (expected, given)\n | _ -> None)\n (fun (expected, given) ->\n Dissection_number_of_sections_mismatch {expected; given}) ;\n let description = \"Invalid number of sections in the dissection\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_dissection_invalid_number_of_sections\"\n ~title:description\n ~description\n ~pp:(fun ppf n ->\n Format.fprintf\n ppf\n \"A dissection with %a sections can never be valid\"\n Z.pp_print\n n)\n Data_encoding.(obj1 (req \"value\" n))\n (function Dissection_invalid_number_of_sections n -> Some n | _ -> None)\n (fun n -> Dissection_invalid_number_of_sections n) ;\n let description = \"Mismatch in the start hash of the dissection\" in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_dissection_start_hash_mismatch\"\n ~title:description\n ~description\n ~pp:(fun ppf (given, expected) ->\n match given with\n | None -> Format.fprintf ppf \"The start hash must not be None\"\n | Some _ ->\n Format.fprintf\n ppf\n \"The start hash should be equal to %a, but the provided hash is %a\"\n pp_hash_opt\n expected\n pp_hash_opt\n given)\n Data_encoding.(\n obj2\n (req \"expected\" (option Sc_rollup_repr.State_hash.encoding))\n (req \"given\" (option Sc_rollup_repr.State_hash.encoding)))\n (function\n | Dissection_start_hash_mismatch {expected; given} ->\n Some (expected, given)\n | _ -> None)\n (fun (expected, given) -> Dissection_start_hash_mismatch {expected; given}) ;\n let description = \"Mismatch in the stop hash of the dissection\" in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_dissection_stop_hash_mismatch\"\n ~title:description\n ~description\n ~pp:(fun ppf h ->\n Format.fprintf ppf \"The stop hash should not be equal to %a\" pp_hash_opt h)\n Data_encoding.(\n obj1 (req \"hash\" (option Sc_rollup_repr.State_hash.encoding)))\n (function Dissection_stop_hash_mismatch hopt -> Some hopt | _ -> None)\n (fun hopt -> Dissection_stop_hash_mismatch hopt) ;\n let description = \"Mismatch in the edge ticks of the dissection\" in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_dissection_edge_ticks_mismatch\"\n ~title:description\n ~description\n ~pp:\n (fun ppf\n ( dissection_start_tick,\n dissection_stop_tick,\n chunk_start_tick,\n chunk_stop_tick ) ->\n Sc_rollup_tick_repr.(\n Format.fprintf\n ppf\n \"We should have dissection_start_tick(%a) = %a and \\\n dissection_stop_tick(%a) = %a\"\n pp\n dissection_start_tick\n pp\n chunk_start_tick\n pp\n dissection_stop_tick\n pp\n chunk_stop_tick))\n Data_encoding.(\n obj4\n (req \"dissection_start_tick\" Sc_rollup_tick_repr.encoding)\n (req \"dissection_stop_tick\" Sc_rollup_tick_repr.encoding)\n (req \"chunk_start_tick\" Sc_rollup_tick_repr.encoding)\n (req \"chunk_stop_tick\" Sc_rollup_tick_repr.encoding))\n (function\n | Dissection_edge_ticks_mismatch e ->\n Some\n ( e.dissection_start_tick,\n e.dissection_stop_tick,\n e.chunk_start_tick,\n e.chunk_stop_tick )\n | _ -> None)\n (fun ( dissection_start_tick,\n dissection_stop_tick,\n chunk_start_tick,\n chunk_stop_tick ) ->\n Dissection_edge_ticks_mismatch\n {\n dissection_start_tick;\n dissection_stop_tick;\n chunk_start_tick;\n chunk_stop_tick;\n }) ;\n let description = \"Ticks should only increase in dissection\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_dissection_ticks_not_increasing\"\n ~title:description\n ~description\n ~pp:(fun ppf () -> Format.pp_print_string ppf description)\n Data_encoding.empty\n (function Dissection_ticks_not_increasing -> Some () | _ -> None)\n (fun () -> Dissection_ticks_not_increasing) ;\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_dissection_invalid_distribution\"\n ~title:description\n ~description\n ~pp:(fun ppf max ->\n Format.fprintf\n ppf\n \"Maximum tick increment in a section cannot be more than %a ticks\"\n Z.pp_print\n max)\n Data_encoding.(obj1 (req \"section_max_size\" n))\n (function Dissection_invalid_distribution max -> Some max | _ -> None)\n (fun max -> Dissection_invalid_distribution max) ;\n let description = \"Cannot recover from a blocked state in a dissection\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_dissection_invalid_successive_states_shape\"\n ~title:description\n ~description\n ~pp:(fun ppf () -> Format.pp_print_string ppf description)\n Data_encoding.empty\n (function\n | Dissection_invalid_successive_states_shape -> Some () | _ -> None)\n (fun () -> Dissection_invalid_successive_states_shape)\n" ;
} ;
{ name = "Sc_rollup_PVM_sig" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module introduces the semantics of Proof-generating Virtual Machines.\n\n A PVM defines an operational semantics for some computational model. The\n specificity of PVMs, in comparison with standard virtual machines, is their\n ability to generate and to validate a *compact* proof that a given atomic\n execution step turned a given state into another one.\n\n In the smart-contract rollups, PVMs are used for two purposes:\n\n - They allow for the externalization of rollup execution by completely\n specifying the operational semantics of a given rollup. This\n standardization of the semantics gives a unique and executable source of\n truth about the interpretation of smart-contract rollup inboxes, seen as a\n transformation of a rollup state.\n\n - They allow for the validation or refutation of a claim that the processing\n of some messages led to a given new rollup state (given an actual source\n of truth about the nature of these messages).\n*)\n\n(** An input to a PVM is the [message_counter] element of an inbox at\n a given [inbox_level] and contains a given [payload].\n\n According the rollup management protocol, the payload must be obtained\n through {!Sc_rollup_inbox_message_repr.serialize} which follows a documented\n format.\n*)\n\ntype inbox_message = {\n inbox_level : Raw_level_repr.t;\n message_counter : Z.t;\n payload : Sc_rollup_inbox_message_repr.serialized;\n}\n\ntype reveal_data =\n | Raw_data of string\n | Metadata of Sc_rollup_metadata_repr.t\n | Dal_page of Dal_slot_repr.Page.content option\n\ntype input = Inbox_message of inbox_message | Reveal of reveal_data\n\nlet pp_inbox_message fmt {inbox_level; message_counter; _} =\n Format.fprintf\n fmt\n \"@[<v 2>level: %a@,message index: %a@]\"\n Raw_level_repr.pp\n inbox_level\n Z.pp_print\n message_counter\n\nlet pp_reveal_data fmt = function\n | Raw_data _ -> Format.pp_print_string fmt \"raw data\"\n | Metadata metadata -> Sc_rollup_metadata_repr.pp fmt metadata\n | Dal_page content_opt ->\n Format.pp_print_option\n ~none:(fun fmt () -> Format.pp_print_string fmt \"<No_dal_data>\")\n (fun fmt _a -> Format.fprintf fmt \"<Some_dal_data>\")\n fmt\n content_opt\n\nlet pp_input fmt = function\n | Inbox_message msg ->\n Format.fprintf fmt \"@[<v 2>inbox message:@,%a@]\" pp_inbox_message msg\n | Reveal reveal ->\n Format.fprintf fmt \"@[<v 2>reveal: %a@]\" pp_reveal_data reveal\n\n(** [inbox_message_encoding] encoding value for {!inbox_message}. *)\nlet inbox_message_encoding =\n let open Data_encoding in\n conv\n (fun {inbox_level; message_counter; payload} ->\n (inbox_level, message_counter, (payload :> string)))\n (fun (inbox_level, message_counter, payload) ->\n let payload = Sc_rollup_inbox_message_repr.unsafe_of_string payload in\n {inbox_level; message_counter; payload})\n (obj3\n (req \"inbox_level\" Raw_level_repr.encoding)\n (req \"message_counter\" n)\n (req \"payload\" (string Hex)))\n\nlet reveal_data_encoding =\n let open Data_encoding in\n let case_raw_data =\n case\n ~title:\"raw data\"\n (Tag 0)\n (obj2\n (req \"reveal_data_kind\" (constant \"raw_data\"))\n (req\n \"raw_data\"\n (check_size\n Constants_repr.sc_rollup_message_size_limit\n Variable.(string Hex))))\n (function Raw_data m -> Some ((), m) | _ -> None)\n (fun ((), m) -> Raw_data m)\n and case_metadata =\n case\n ~title:\"metadata\"\n (Tag 1)\n (obj2\n (req \"reveal_data_kind\" (constant \"metadata\"))\n (req \"metadata\" Sc_rollup_metadata_repr.encoding))\n (function Metadata md -> Some ((), md) | _ -> None)\n (fun ((), md) -> Metadata md)\n in\n let case_dal_page =\n case\n ~title:\"dal page\"\n (Tag 2)\n (obj2\n (req \"reveal_data_kind\" (constant \"dal_page\"))\n (req \"dal_page_content\" (option (bytes Hex))))\n (function Dal_page p -> Some ((), p) | _ -> None)\n (fun ((), p) -> Dal_page p)\n in\n union [case_raw_data; case_metadata; case_dal_page]\n\nlet input_encoding =\n let open Data_encoding in\n let case_inbox_message =\n case\n ~title:\"inbox msg\"\n (Tag 0)\n (obj2\n (req \"input_kind\" (constant \"inbox_message\"))\n (req \"inbox_message\" inbox_message_encoding))\n (function Inbox_message m -> Some ((), m) | _ -> None)\n (fun ((), m) -> Inbox_message m)\n and case_reveal_revelation =\n case\n ~title:\"reveal\"\n (Tag 1)\n (obj2\n (req \"input_kind\" (constant \"reveal_revelation\"))\n (req \"reveal_data\" reveal_data_encoding))\n (function Reveal d -> Some ((), d) | _ -> None)\n (fun ((), d) -> Reveal d)\n in\n union [case_inbox_message; case_reveal_revelation]\n\n(** [input_equal i1 i2] return whether [i1] and [i2] are equal. *)\nlet inbox_message_equal a b =\n let {inbox_level; message_counter; payload} = a in\n (* To be robust to the addition of fields in [input] *)\n Raw_level_repr.equal inbox_level b.inbox_level\n && Z.equal message_counter b.message_counter\n && String.equal (payload :> string) (b.payload :> string)\n\nlet reveal_data_equal a b =\n match (a, b) with\n | Raw_data a, Raw_data b -> String.equal a b\n | Raw_data _, _ -> false\n | Metadata a, Metadata b -> Sc_rollup_metadata_repr.equal a b\n | Metadata _, _ -> false\n | Dal_page a, Dal_page b -> Option.equal Bytes.equal a b\n | Dal_page _, _ -> false\n\nlet input_equal a b =\n match (a, b) with\n | Inbox_message a, Inbox_message b -> inbox_message_equal a b\n | Inbox_message _, _ -> false\n | Reveal a, Reveal b -> reveal_data_equal a b\n | Reveal _, _ -> false\n\nmodule Input_hash =\n Blake2B.Make\n (Base58)\n (struct\n let name = \"Smart_rollup_input_hash\"\n\n let title = \"A smart rollup input hash\"\n\n let b58check_prefix =\n \"\\001\\118\\125\\135\" (* \"scd1(37)\" decoded from base 58. *)\n\n let size = Some 20\n end)\n\ntype reveal =\n | Reveal_raw_data of Sc_rollup_reveal_hash.t\n | Reveal_metadata\n | Request_dal_page of Dal_slot_repr.Page.t\n\nlet reveal_encoding =\n let open Data_encoding in\n let case_raw_data =\n case\n ~title:\"Reveal_raw_data\"\n (Tag 0)\n (obj2\n (req \"reveal_kind\" (constant \"reveal_raw_data\"))\n (req \"input_hash\" Sc_rollup_reveal_hash.encoding))\n (function Reveal_raw_data s -> Some ((), s) | _ -> None)\n (fun ((), s) -> Reveal_raw_data s)\n and case_metadata =\n case\n ~title:\"Reveal_metadata\"\n (Tag 1)\n (obj1 (req \"reveal_kind\" (constant \"reveal_metadata\")))\n (function Reveal_metadata -> Some () | _ -> None)\n (fun () -> Reveal_metadata)\n in\n let case_dal_page =\n case\n ~title:\"Request_dal_page\"\n (Tag 2)\n (obj2\n (req \"reveal_kind\" (constant \"request_dal_page\"))\n (req \"page_id\" Dal_slot_repr.Page.encoding))\n (function Request_dal_page s -> Some ((), s) | _ -> None)\n (fun ((), s) -> Request_dal_page s)\n in\n union [case_raw_data; case_metadata; case_dal_page]\n\n(** The PVM's current input expectations:\n - [No_input_required] if the machine is busy and has no need for new input.\n\n - [Initial] if the machine has never received an input so expects the very\n first item in the inbox.\n\n - [First_after (level, counter)] expects whatever comes next after that\n position in the inbox.\n\n - [Needs_metadata] if the machine needs the metadata to continue\n its execution.\n*)\ntype input_request =\n | No_input_required\n | Initial\n | First_after of Raw_level_repr.t * Z.t\n | Needs_reveal of reveal\n\n(** [input_request_encoding] encoding value for {!input_request}. *)\nlet input_request_encoding =\n let open Data_encoding in\n union\n ~tag_size:`Uint8\n [\n case\n ~title:\"No_input_required\"\n (Tag 0)\n (obj1 (req \"input_request_kind\" (constant \"no_input_required\")))\n (function No_input_required -> Some () | _ -> None)\n (fun () -> No_input_required);\n case\n ~title:\"Initial\"\n (Tag 1)\n (obj1 (req \"input_request_kind\" (constant \"initial\")))\n (function Initial -> Some () | _ -> None)\n (fun () -> Initial);\n case\n ~title:\"First_after\"\n (Tag 2)\n (obj3\n (req \"input_request_kind\" (constant \"first_after\"))\n (req \"level\" Raw_level_repr.encoding)\n (req \"counter\" n))\n (function\n | First_after (level, counter) -> Some ((), level, counter)\n | _ -> None)\n (fun ((), level, counter) -> First_after (level, counter));\n case\n ~title:\"Needs_reveal\"\n (Tag 3)\n (obj2\n (req \"input_request_kind\" (constant \"needs_reveal\"))\n (req \"reveal\" reveal_encoding))\n (function Needs_reveal p -> Some ((), p) | _ -> None)\n (fun ((), p) -> Needs_reveal p);\n ]\n\nlet pp_reveal fmt = function\n | Reveal_raw_data hash -> Sc_rollup_reveal_hash.pp fmt hash\n | Reveal_metadata -> Format.pp_print_string fmt \"Reveal metadata\"\n | Request_dal_page id -> Dal_slot_repr.Page.pp fmt id\n\n(** [pp_input_request fmt i] pretty prints the given input [i] to the formatter\n [fmt]. *)\nlet pp_input_request fmt request =\n match request with\n | No_input_required -> Format.fprintf fmt \"No_input_required\"\n | Initial -> Format.fprintf fmt \"Initial\"\n | First_after (l, n) ->\n Format.fprintf\n fmt\n \"First_after (level = %a, counter = %a)\"\n Raw_level_repr.pp\n l\n Z.pp_print\n n\n | Needs_reveal reveal ->\n Format.fprintf fmt \"Needs reveal of %a\" pp_reveal reveal\n\nlet reveal_equal p1 p2 =\n match (p1, p2) with\n | Reveal_raw_data h1, Reveal_raw_data h2 -> Sc_rollup_reveal_hash.equal h1 h2\n | Reveal_metadata, Reveal_metadata -> true\n | Request_dal_page a, Request_dal_page b -> Dal_slot_repr.Page.equal a b\n | (Reveal_raw_data _ | Reveal_metadata | Request_dal_page _), _ -> false\n\n(** [input_request_equal i1 i2] return whether [i1] and [i2] are equal. *)\nlet input_request_equal a b =\n match (a, b) with\n | No_input_required, No_input_required -> true\n | No_input_required, _ -> false\n | Initial, Initial -> true\n | Initial, _ -> false\n | First_after (l, n), First_after (m, o) ->\n Raw_level_repr.equal l m && Z.equal n o\n | First_after _, _ -> false\n | Needs_reveal p1, Needs_reveal p2 -> reveal_equal p1 p2\n | Needs_reveal _, _ -> false\n\n(** Type that describes output values. *)\ntype output = {\n outbox_level : Raw_level_repr.t;\n (** The outbox level containing the message. The level corresponds to the\n inbox level for which the message was produced. *)\n message_index : Z.t; (** The message index. *)\n message : Sc_rollup_outbox_message_repr.t; (** The message itself. *)\n}\n\n(** [output_encoding] encoding value for {!output}. *)\nlet output_encoding =\n let open Data_encoding in\n conv\n (fun {outbox_level; message_index; message} ->\n (outbox_level, message_index, message))\n (fun (outbox_level, message_index, message) ->\n {outbox_level; message_index; message})\n (obj3\n (req \"outbox_level\" Raw_level_repr.encoding)\n (req \"message_index\" n)\n (req \"message\" Sc_rollup_outbox_message_repr.encoding))\n\n(** [pp_output fmt o] pretty prints the given output [o] to the formatter\n [fmt]. *)\nlet pp_output fmt {outbox_level; message_index; message} =\n Format.fprintf\n fmt\n \"@[%a@;%a@;%a@;@]\"\n Raw_level_repr.pp\n outbox_level\n Z.pp_print\n message_index\n Sc_rollup_outbox_message_repr.pp\n message\n\nmodule type S = sig\n (** The state of the PVM denotes a state of the rollup.\n\n The life cycle of the PVM is as follows. It starts its execution\n from an {!initial_state}. The initial state is specialized at\n origination with a [boot_sector], using the\n {!install_boot_sector} function. The resulting state is call the\n \226\128\156genesis\226\128\157 of the rollup.\n\n Afterwards, we classify states into two categories: \"internal\n states\" do not require any external information to be executed\n while \"input states\" are waiting for some information from the\n inbox to be executable. *)\n type state\n\n val pp : state -> (Format.formatter -> unit -> unit) Lwt.t\n\n (** A [context] represents the executable environment needed by the state to\n exist. Typically, the rollup node storage can be part of this context to\n allow the PVM state to be persistent. *)\n type context\n\n (** A [hash] characterizes the contents of a state. *)\n type hash = Sc_rollup_repr.State_hash.t\n\n (** During interactive refutation games, a player may need to provide a proof\n that a given execution step is valid. The PVM implementation is\n responsible for ensuring that this proof type has the correct semantics.\n\n A proof [p] has four parameters:\n\n - [start_hash := proof_start_state p]\n - [stop_hash := proof_stop_state p]\n - [input_requested := proof_input_requested p]\n - [input_given := proof_input_given p]\n\n The following predicate must hold of a valid proof:\n\n [exists start_state, stop_state.\n (state_hash start_state == start_hash)\n AND (Option.map state_hash stop_state == stop_hash)\n AND (is_input_state start_state == input_requested)\n AND (match (input_given, input_requested) with\n | (None, No_input_required) -> eval start_state == stop_state\n | (None, Initial) -> stop_state == None\n | (None, First_after (l, n)) -> stop_state == None\n | (Some input, No_input_required) -> true\n | (Some input, Initial) ->\n set_input input_given start_state == stop_state\n | (Some input, First_after (l, n)) ->\n set_input input_given start_state == stop_state)]\n\n In natural language---the two hash parameters [start_hash] and [stop_hash]\n must have actual [state] values (or possibly [None] in the case of\n [stop_hash]) of which they are the hashes. The [input_requested] parameter\n must be the correct request from the [start_hash], given according to\n [is_input_state]. Finally there are four possibilities of [input_requested]\n and [input_given].\n\n - if no input is required, or given, the proof is a simple [eval]\n step ;\n - if input was required but not given, the [stop_hash] must be\n [None] (the machine is blocked) ;\n - if no input was required but some was given, this makes no sense\n and it doesn't matter if the proof is valid or invalid (this\n case will be ruled out by the inbox proof anyway) ;\n - finally, if input was required and given, the proof is a\n [set_input] step. *)\n type proof\n\n (** [proof]s are embedded in L1 refutation game operations using\n [proof_encoding]. Given that the size of L1 operations are limited, it is\n of *critical* importance to make sure that no execution step of the PVM\n can generate proofs that do not fit in L1 operations when encoded. If such\n a proof existed, the rollup could get stuck. *)\n val proof_encoding : proof Data_encoding.t\n\n (** [proof_start_state proof] returns the initial state hash of the [proof]\n execution step. *)\n val proof_start_state : proof -> hash\n\n (** [proof_stop_state proof] returns the final state hash of the [proof]\n execution step. *)\n val proof_stop_state : proof -> hash\n\n (** [state_hash state] returns a compressed representation of [state]. *)\n val state_hash : state -> hash Lwt.t\n\n (** [initial_state ~empty] is the initial state of the PVM, before its\n specialization with a given [boot_sector]. The initial state is built on\n the [empty] state which must be provided. *)\n val initial_state : empty:state -> state Lwt.t\n\n (** [install_boot_sector state boot_sector] specializes the initial\n [state] of a PVM using a dedicated [boot_sector], submitted at\n the origination of the rollup. *)\n val install_boot_sector : state -> string -> state Lwt.t\n\n (** [is_input_state state] returns the input expectations of the\n [state]---does it need input, and if so, how far through the inbox\n has it read so far? *)\n val is_input_state : state -> input_request Lwt.t\n\n (** [set_input input state] sets [input] in [state] as the next\n input to be processed. This must answer the [input_request]\n from [is_input_state state]. *)\n val set_input : input -> state -> state Lwt.t\n\n (** [eval s0] returns a state [s1] resulting from the\n execution of an atomic step of the rollup at state [s0]. *)\n val eval : state -> state Lwt.t\n\n (** [verify_proof input p] checks the proof [p] with input [input] and returns\n the [input_request] before the evaluation of the proof. See the doc-string\n for the [proof] type.\n\n [verify_proof input p] fails when the proof is invalid in regards to the\n given input. *)\n val verify_proof : input option -> proof -> input_request tzresult Lwt.t\n\n (** [produce_proof ctxt input_given state] should return a [proof] for\n the PVM step starting from [state], if possible. This may fail for\n a few reasons:\n - the [input_given] doesn't match the expectations of [state] ;\n - the [context] for this instance of the PVM doesn't have access\n to enough of the [state] to build the proof. *)\n val produce_proof : context -> input option -> state -> proof tzresult Lwt.t\n\n (** [verify_origination_proof proof boot_sector] verifies a proof\n supposedly generated by [produce_origination_proof]. *)\n val verify_origination_proof : proof -> string -> bool Lwt.t\n\n (** [produce_origination_proof context boot_sector] produces a proof\n [p] covering the specialization of a PVM, from the\n [initial_state] up to the genesis state wherein the\n [boot_sector] has been installed. *)\n val produce_origination_proof : context -> string -> proof tzresult Lwt.t\n\n (** The following type is inhabited by the proofs that a given [output]\n is part of the outbox of a given [state]. *)\n type output_proof\n\n (** [output_proof_encoding] encoding value for [output_proof]s. *)\n val output_proof_encoding : output_proof Data_encoding.t\n\n (** [output_of_output_proof proof] returns the [output] that is referred to in\n [proof]'s statement. *)\n val output_of_output_proof : output_proof -> output\n\n (** [state_of_output_proof proof] returns the [state] hash that is referred to\n in [proof]'s statement. *)\n val state_of_output_proof : output_proof -> hash\n\n (** [verify_output_proof output_proof] returns [true] iff [proof] is a valid\n witness that its [output] is part of its [state]'s outbox. *)\n val verify_output_proof : output_proof -> bool Lwt.t\n\n (** [produce_output_proof ctxt state output] returns a proof that witnesses\n the fact that [output] is part of [state]'s outbox. *)\n val produce_output_proof :\n context -> state -> output -> (output_proof, error) result Lwt.t\n\n (** [check_dissection ~default_number_of_sections ~start_chunk\n ~stop_chunk chunks] fails if the dissection encoded by the list\n [[start_chunk] @ chunks @ [stop_chunk]] does not satisfy the\n properties expected by the PVM. *)\n val check_dissection :\n default_number_of_sections:int ->\n start_chunk:Sc_rollup_dissection_chunk_repr.t ->\n stop_chunk:Sc_rollup_dissection_chunk_repr.t ->\n Sc_rollup_dissection_chunk_repr.t list ->\n unit tzresult\n\n (** [get_current_level state] returns the current level of the [state],\n returns [None] if it is not possible to compute the level. *)\n val get_current_level : state -> Raw_level_repr.t option Lwt.t\n\n module Internal_for_tests : sig\n (** [insert_failure state] corrupts the PVM state. This is used in\n the loser mode of the rollup node. *)\n val insert_failure : state -> state Lwt.t\n end\nend\n" ;
} ;
{ name = "Sc_rollup_arith" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module provides a temporary toy rollup to be used as a demo. *)\n\n(*\n FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/3995\n Use EOL/SOL once merged to import Dal pages.\n*)\n\n(**\n\n This rollup is a stack machine equipped with addition.\n\n It processes postfix arithmetic expressions written as sequence of\n (space separated) [int] and [+] using the following rules:\n\n - a number [x] is interpreted as pushing [x] on the stack ;\n\n - a variable [a] is interpreted as storing the topmost element of the\n stack in the storage under the name \"a\" ;\n\n - a variable [out] is interpreted as adding a message to the outbox\n containing a single transaction batch with the topmost element of the\n stack as payload, the zero contract as destination, and a default\n entrypoint ;\n\n - a symbol [+] pops two integers [x] and [y] and pushes [x + y] on\n the stack ;\n\n - an input [hash:<HASH>] is interpreted as a directive to request the DAC\n data whose hash is <HASH> ;\n\n - an input [dal:<LVL>:<SID>:<PID>] is interpreted as a directive to request\n the DAL page whose index is <PID> belonging to slot index <SID> confirmed\n at level <LVL> (i.e published at level LVL - attestation_lag) ;\n\n If a message is not syntactically correct or does not evaluate\n correctly, the machine stops its evaluation and waits for the next\n message.\n\n The machine has a boot sector which is a mere string used a prefix\n for each message.\n\n The module implements the {!Sc_rollup_PVM_sig.S}\195\142 interface to be\n used in the smart contract rollup infrastructure.\n\n The machine exposes extra operations to be used in the rollup node.\n\n*)\nmodule type S = sig\n include Sc_rollup_PVM_sig.S\n\n (** [parse_boot_sector s] builds a boot sector from its human\n writable description. *)\n val parse_boot_sector : string -> string option\n\n (** [pp_boot_sector fmt s] prints a human readable representation of\n a boot sector. *)\n val pp_boot_sector : Format.formatter -> string -> unit\n\n (** [pp state] returns a pretty-printer valid for [state]. *)\n val pp : state -> (Format.formatter -> unit -> unit) Lwt.t\n\n (** [get_tick state] returns the current tick of [state]. *)\n val get_tick : state -> Sc_rollup_tick_repr.t Lwt.t\n\n (** The machine has five possible statuses: *)\n type status =\n | Halted\n | Waiting_for_input_message\n | Waiting_for_reveal\n | Waiting_for_metadata\n | Parsing\n | Evaluating\n\n (** [get_status state] returns the machine status in [state]. *)\n val get_status : state -> status Lwt.t\n\n (** [get_outbox outbox_level state] returns the outbox in [state]\n for a given [outbox_level]. *)\n val get_outbox :\n Raw_level_repr.t -> state -> Sc_rollup_PVM_sig.output list Lwt.t\n\n (** The machine has only three instructions. *)\n type instruction =\n | IPush : int -> instruction\n | IAdd : instruction\n | IStore : string -> instruction\n\n (** [equal_instruction i1 i2] is [true] iff [i1] equals [i2]. *)\n val equal_instruction : instruction -> instruction -> bool\n\n (** [pp_instruction fmt i] shows a human readable representation of [i]. *)\n val pp_instruction : Format.formatter -> instruction -> unit\n\n (** [get_parsing_result state] is [Some true] if the current\n message is syntactically correct, [Some false] when it\n contains a syntax error, and [None] when the machine is\n not in parsing state. *)\n val get_parsing_result : state -> bool option Lwt.t\n\n (** [get_code state] returns the current code obtained by parsing\n the current input message. *)\n val get_code : state -> instruction list Lwt.t\n\n (** [get_stack state] returns the current stack. *)\n val get_stack : state -> int list Lwt.t\n\n (** [get_var state x] returns the current value of variable [x].\n Returns [None] if [x] does not exist. *)\n val get_var : state -> string -> int option Lwt.t\n\n (** [get_evaluation_result state] returns [Some true] if the current\n message evaluation succeeds, [Some false] if it failed, and\n [None] if the evaluation has not been done yet. *)\n val get_evaluation_result : state -> bool option Lwt.t\n\n (** [get_is_stuck state] returns [Some err] if some internal error\n made the machine fail during the last evaluation step. [None]\n if no internal error occurred. When a machine is stuck, it\n reboots, waiting for the next message to process. *)\n val get_is_stuck : state -> string option Lwt.t\nend\n\nmodule Protocol_implementation :\n S\n with type context = Context.t\n and type state = Context.tree\n and type proof = Context.Proof.tree Context.Proof.t\n\n(** This is the state hash of reference that both the prover of the\n node and the verifier of the protocol {!Protocol_implementation}\n have to agree on (if they do, it means they are using the same\n tree structure). *)\nval reference_initial_state_hash : Sc_rollup_repr.State_hash.t\n\nmodule type P = sig\n module Tree : Context.TREE with type key = string list and type value = bytes\n\n type tree = Tree.tree\n\n val hash_tree : tree -> Sc_rollup_repr.State_hash.t\n\n type proof\n\n val proof_encoding : proof Data_encoding.t\n\n val proof_before : proof -> Sc_rollup_repr.State_hash.t\n\n val proof_after : proof -> Sc_rollup_repr.State_hash.t\n\n val verify_proof :\n proof -> (tree -> (tree * 'a) Lwt.t) -> (tree * 'a) option Lwt.t\n\n val produce_proof :\n Tree.t -> tree -> (tree -> (tree * 'a) Lwt.t) -> (proof * 'a) option Lwt.t\nend\n\nmodule Make (Context : P) :\n S\n with type context = Context.Tree.t\n and type state = Context.tree\n and type proof = Context.proof\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Sc_rollup_repr\nmodule PS = Sc_rollup_PVM_sig\n\n(*\n This is the state hash of reference that both the prover of the node\n and the verifier of the protocol {!Protocol_implementation} have to\n agree on (if they do, it means they are using the same tree\n structure).\n\n We have to hard-code this value because the Arith PVM uses Irmin as\n its Merkle proof verification backend, and the economic protocol\n cannot create an empty Irmin context. Such a context is required to\n create an empty tree, itself required to create the initial state of\n the Arith PVM.\n\n Utlimately, the value of this constant is decided by the prover of\n reference (the only need is for it to be compatible with\n {!Protocol_implementation}.)\n\n Its value is the result of the following snippet\n\n {|\n let*! state = Prover.initial_state ~empty in\n Prover.state_hash state\n |}\n*)\nlet reference_initial_state_hash =\n State_hash.of_b58check_exn\n \"srs11Z9V76SGd97kGmDQXV8tEF67C48GMy77RuaHdF1kWLk6UTmMfj\"\n\ntype error +=\n | Arith_proof_production_failed\n | Arith_output_proof_production_failed\n | Arith_invalid_claim_about_outbox\n\nlet () =\n let open Data_encoding in\n let msg = \"Invalid claim about outbox\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_arith_invalid_claim_about_outbox\"\n ~title:msg\n ~pp:(fun fmt () -> Format.pp_print_string fmt msg)\n ~description:msg\n unit\n (function Arith_invalid_claim_about_outbox -> Some () | _ -> None)\n (fun () -> Arith_invalid_claim_about_outbox) ;\n let msg = \"Output proof production failed\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_arith_output_proof_production_failed\"\n ~title:msg\n ~pp:(fun fmt () -> Format.fprintf fmt \"%s\" msg)\n ~description:msg\n unit\n (function Arith_output_proof_production_failed -> Some () | _ -> None)\n (fun () -> Arith_output_proof_production_failed) ;\n let msg = \"Proof production failed\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_arith_proof_production_failed\"\n ~title:msg\n ~pp:(fun fmt () -> Format.fprintf fmt \"%s\" msg)\n ~description:msg\n unit\n (function Arith_proof_production_failed -> Some () | _ -> None)\n (fun () -> Arith_proof_production_failed)\n\nmodule type P = sig\n module Tree : Context.TREE with type key = string list and type value = bytes\n\n type tree = Tree.tree\n\n val hash_tree : tree -> State_hash.t\n\n type proof\n\n val proof_encoding : proof Data_encoding.t\n\n val proof_before : proof -> State_hash.t\n\n val proof_after : proof -> State_hash.t\n\n val verify_proof :\n proof -> (tree -> (tree * 'a) Lwt.t) -> (tree * 'a) option Lwt.t\n\n val produce_proof :\n Tree.t -> tree -> (tree -> (tree * 'a) Lwt.t) -> (proof * 'a) option Lwt.t\nend\n\nmodule type S = sig\n include PS.S\n\n val parse_boot_sector : string -> string option\n\n val pp_boot_sector : Format.formatter -> string -> unit\n\n val pp : state -> (Format.formatter -> unit -> unit) Lwt.t\n\n val get_tick : state -> Sc_rollup_tick_repr.t Lwt.t\n\n type status =\n | Halted\n | Waiting_for_input_message\n | Waiting_for_reveal\n | Waiting_for_metadata\n | Parsing\n | Evaluating\n\n val get_status : state -> status Lwt.t\n\n val get_outbox :\n Raw_level_repr.t -> state -> Sc_rollup_PVM_sig.output list Lwt.t\n\n type instruction =\n | IPush : int -> instruction\n | IAdd : instruction\n | IStore : string -> instruction\n\n val equal_instruction : instruction -> instruction -> bool\n\n val pp_instruction : Format.formatter -> instruction -> unit\n\n val get_parsing_result : state -> bool option Lwt.t\n\n val get_code : state -> instruction list Lwt.t\n\n val get_stack : state -> int list Lwt.t\n\n val get_var : state -> string -> int option Lwt.t\n\n val get_evaluation_result : state -> bool option Lwt.t\n\n val get_is_stuck : state -> string option Lwt.t\nend\n\nmodule Make (Context : P) :\n S\n with type context = Context.Tree.t\n and type state = Context.tree\n and type proof = Context.proof = struct\n module Tree = Context.Tree\n\n type context = Context.Tree.t\n\n type hash = State_hash.t\n\n type proof = Context.proof\n\n let proof_encoding = Context.proof_encoding\n\n let proof_start_state proof = Context.proof_before proof\n\n let proof_stop_state proof = Context.proof_after proof\n\n let parse_boot_sector s = Some s\n\n let pp_boot_sector fmt s = Format.fprintf fmt \"%s\" s\n\n type tree = Tree.tree\n\n type status =\n | Halted\n | Waiting_for_input_message\n | Waiting_for_reveal\n | Waiting_for_metadata\n | Parsing\n | Evaluating\n\n type instruction =\n | IPush : int -> instruction\n | IAdd : instruction\n | IStore : string -> instruction\n\n let equal_instruction i1 i2 =\n match (i1, i2) with\n | IPush x, IPush y -> Compare.Int.(x = y)\n | IAdd, IAdd -> true\n | IStore x, IStore y -> Compare.String.(x = y)\n | _, _ -> false\n\n let pp_instruction fmt = function\n | IPush x -> Format.fprintf fmt \"push(%d)\" x\n | IAdd -> Format.fprintf fmt \"add\"\n | IStore x -> Format.fprintf fmt \"store(%s)\" x\n\n let check_dissection ~default_number_of_sections ~start_chunk ~stop_chunk =\n let open Sc_rollup_dissection_chunk_repr in\n let dist = Sc_rollup_tick_repr.distance start_chunk.tick stop_chunk.tick in\n let section_maximum_size = Z.div dist (Z.of_int 2) in\n Sc_rollup_dissection_chunk_repr.(\n default_check\n ~section_maximum_size\n ~check_sections_number:default_check_sections_number\n ~default_number_of_sections\n ~start_chunk\n ~stop_chunk)\n\n (*\n\n The machine state is represented using a Merkle tree.\n\n Here is the data model of this state represented in the tree:\n\n - tick : Sc_rollup_tick_repr.t\n The current tick counter of the machine.\n - status : status\n The current status of the machine.\n - stack : int deque\n The stack of integers.\n - next_message : string option\n The current input message to be processed.\n - code : instruction deque\n The instructions parsed from the input message.\n - lexer_state : int * int\n The internal state of the lexer.\n - parsing_state : parsing_state\n The internal state of the parser.\n - parsing_result : bool option\n The outcome of parsing.\n - evaluation_result : bool option\n The outcome of evaluation.\n\n *)\n module State = struct\n type state = tree\n\n module Monad : sig\n type 'a t\n\n val run : 'a t -> state -> (state * 'a option) Lwt.t\n\n val is_stuck : string option t\n\n val internal_error : string -> 'a t\n\n val return : 'a -> 'a t\n\n module Syntax : sig\n val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t\n end\n\n val remove : Tree.key -> unit t\n\n val find_value : Tree.key -> 'a Data_encoding.t -> 'a option t\n\n val children : Tree.key -> 'a Data_encoding.t -> (string * 'a) list t\n\n val get_value : default:'a -> Tree.key -> 'a Data_encoding.t -> 'a t\n\n val set_value : Tree.key -> 'a Data_encoding.t -> 'a -> unit t\n end = struct\n type 'a t = state -> (state * 'a option) Lwt.t\n\n let return x state = Lwt.return (state, Some x)\n\n let bind m f state =\n let open Lwt_syntax in\n let* state, res = m state in\n match res with None -> return (state, None) | Some res -> f res state\n\n module Syntax = struct\n let ( let* ) = bind\n end\n\n let run m state = m state\n\n let internal_error_key = [\"internal_error\"]\n\n let internal_error msg tree =\n let open Lwt_syntax in\n let* tree = Tree.add tree internal_error_key (Bytes.of_string msg) in\n return (tree, None)\n\n let is_stuck tree =\n let open Lwt_syntax in\n let* v = Tree.find tree internal_error_key in\n return (tree, Some (Option.map Bytes.to_string v))\n\n let remove key tree =\n let open Lwt_syntax in\n let* tree = Tree.remove tree key in\n return (tree, Some ())\n\n let decode encoding bytes state =\n let open Lwt_syntax in\n match Data_encoding.Binary.of_bytes_opt encoding bytes with\n | None -> internal_error \"Error during decoding\" state\n | Some v -> return (state, Some v)\n\n let find_value key encoding state =\n let open Lwt_syntax in\n let* obytes = Tree.find state key in\n match obytes with\n | None -> return (state, Some None)\n | Some bytes ->\n let* state, value = decode encoding bytes state in\n return (state, Some value)\n\n let children key encoding state =\n let open Lwt_syntax in\n let* children = Tree.list state key in\n let rec aux = function\n | [] -> return (state, Some [])\n | (key, tree) :: children -> (\n let* obytes = Tree.to_value tree in\n match obytes with\n | None -> internal_error \"Invalid children\" state\n | Some bytes -> (\n let* state, v = decode encoding bytes state in\n match v with\n | None -> return (state, None)\n | Some v -> (\n let* state, l = aux children in\n match l with\n | None -> return (state, None)\n | Some l -> return (state, Some ((key, v) :: l)))))\n in\n aux children\n\n let get_value ~default key encoding =\n let open Syntax in\n let* ov = find_value key encoding in\n match ov with None -> return default | Some x -> return x\n\n let set_value key encoding value tree =\n let open Lwt_syntax in\n Data_encoding.Binary.to_bytes_opt encoding value |> function\n | None -> internal_error \"Internal_Error during encoding\" tree\n | Some bytes ->\n let* tree = Tree.add tree key bytes in\n return (tree, Some ())\n end\n\n open Monad\n\n module Make_var (P : sig\n type t\n\n val name : string\n\n val initial : t\n\n val pp : Format.formatter -> t -> unit\n\n val encoding : t Data_encoding.t\n end) =\n struct\n let key = [P.name]\n\n let create = set_value key P.encoding P.initial\n\n let get =\n let open Monad.Syntax in\n let* v = find_value key P.encoding in\n match v with\n | None ->\n (* This case should not happen if [create] is properly called. *)\n return P.initial\n | Some v -> return v\n\n let set = set_value key P.encoding\n\n let pp =\n let open Monad.Syntax in\n let* v = get in\n return @@ fun fmt () -> Format.fprintf fmt \"@[%s : %a@]\" P.name P.pp v\n end\n\n module Make_dict (P : sig\n type t\n\n val name : string\n\n val pp : Format.formatter -> t -> unit\n\n val encoding : t Data_encoding.t\n end) =\n struct\n let key k = [P.name; k]\n\n let get k = find_value (key k) P.encoding\n\n let set k v = set_value (key k) P.encoding v\n\n let entries = children [P.name] P.encoding\n\n let mapped_to k v state =\n let open Lwt_syntax in\n let* state', _ = Monad.(run (set k v) state) in\n let* t = Tree.find_tree state (key k)\n and* t' = Tree.find_tree state' (key k) in\n Lwt.return (Option.equal Tree.equal t t')\n\n let pp =\n let open Monad.Syntax in\n let* l = entries in\n let pp_elem fmt (key, value) =\n Format.fprintf fmt \"@[%s : %a@]\" key P.pp value\n in\n return @@ fun fmt () -> Format.pp_print_list pp_elem fmt l\n end\n\n module Make_deque (P : sig\n type t\n\n val name : string\n\n val encoding : t Data_encoding.t\n end) =\n struct\n (*\n\n A stateful deque.\n\n [[head; end[] is the index range for the elements of the deque.\n\n The length of the deque is therefore [end - head].\n\n *)\n\n let head_key = [P.name; \"head\"]\n\n let end_key = [P.name; \"end\"]\n\n let get_head = get_value ~default:Z.zero head_key Data_encoding.z\n\n let set_head = set_value head_key Data_encoding.z\n\n let get_end = get_value ~default:(Z.of_int 0) end_key Data_encoding.z\n\n let set_end = set_value end_key Data_encoding.z\n\n let idx_key idx = [P.name; Z.to_string idx]\n\n let top =\n let open Monad.Syntax in\n let* head_idx = get_head in\n let* end_idx = get_end in\n let* v = find_value (idx_key head_idx) P.encoding in\n if Z.(leq end_idx head_idx) then return None\n else\n match v with\n | None -> (* By invariants of the Deque. *) assert false\n | Some x -> return (Some x)\n\n let push x =\n let open Monad.Syntax in\n let* head_idx = get_head in\n let head_idx' = Z.pred head_idx in\n let* () = set_head head_idx' in\n set_value (idx_key head_idx') P.encoding x\n\n let pop =\n let open Monad.Syntax in\n let* head_idx = get_head in\n let* end_idx = get_end in\n if Z.(leq end_idx head_idx) then return None\n else\n let* v = find_value (idx_key head_idx) P.encoding in\n match v with\n | None -> (* By invariants of the Deque. *) assert false\n | Some x ->\n let* () = remove (idx_key head_idx) in\n let head_idx = Z.succ head_idx in\n let* () = set_head head_idx in\n return (Some x)\n\n let inject x =\n let open Monad.Syntax in\n let* end_idx = get_end in\n let end_idx' = Z.succ end_idx in\n let* () = set_end end_idx' in\n set_value (idx_key end_idx) P.encoding x\n\n let to_list =\n let open Monad.Syntax in\n let* head_idx = get_head in\n let* end_idx = get_end in\n let rec aux l idx =\n if Z.(lt idx head_idx) then return l\n else\n let* v = find_value (idx_key idx) P.encoding in\n match v with\n | None -> (* By invariants of deque *) assert false\n | Some v -> aux (v :: l) (Z.pred idx)\n in\n aux [] (Z.pred end_idx)\n\n let clear = remove [P.name]\n end\n\n module Current_tick = Make_var (struct\n include Sc_rollup_tick_repr\n\n let name = \"tick\"\n end)\n\n module Vars = Make_dict (struct\n type t = int\n\n let name = \"vars\"\n\n let encoding = Data_encoding.int31\n\n let pp fmt x = Format.fprintf fmt \"%d\" x\n end)\n\n module Stack = Make_deque (struct\n type t = int\n\n let name = \"stack\"\n\n let encoding = Data_encoding.int31\n end)\n\n module Code = Make_deque (struct\n type t = instruction\n\n let name = \"code\"\n\n let encoding =\n Data_encoding.(\n union\n [\n case\n ~title:\"push\"\n (Tag 0)\n Data_encoding.int31\n (function IPush x -> Some x | _ -> None)\n (fun x -> IPush x);\n case\n ~title:\"add\"\n (Tag 1)\n Data_encoding.unit\n (function IAdd -> Some () | _ -> None)\n (fun () -> IAdd);\n case\n ~title:\"store\"\n (Tag 2)\n Data_encoding.(string Plain)\n (function IStore x -> Some x | _ -> None)\n (fun x -> IStore x);\n ])\n end)\n\n module Boot_sector = Make_var (struct\n type t = string\n\n let name = \"boot_sector\"\n\n let initial = \"\"\n\n let encoding = Data_encoding.(string Plain)\n\n let pp fmt s = Format.fprintf fmt \"%s\" s\n end)\n\n module Status = Make_var (struct\n type t = status\n\n let initial = Halted\n\n let encoding =\n Data_encoding.string_enum\n [\n (\"Halted\", Halted);\n (\"Waiting_for_input_message\", Waiting_for_input_message);\n (\"Waiting_for_reveal\", Waiting_for_reveal);\n (\"Waiting_for_metadata\", Waiting_for_metadata);\n (\"Parsing\", Parsing);\n (\"Evaluating\", Evaluating);\n ]\n\n let name = \"status\"\n\n let string_of_status = function\n | Halted -> \"Halted\"\n | Waiting_for_input_message -> \"Waiting for input message\"\n | Waiting_for_reveal -> \"Waiting for reveal\"\n | Waiting_for_metadata -> \"Waiting for metadata\"\n | Parsing -> \"Parsing\"\n | Evaluating -> \"Evaluating\"\n\n let pp fmt status = Format.fprintf fmt \"%s\" (string_of_status status)\n end)\n\n module Required_reveal = Make_var (struct\n type t = PS.reveal option\n\n let initial = None\n\n let encoding = Data_encoding.option PS.reveal_encoding\n\n let name = \"required_reveal\"\n\n let pp fmt v =\n match v with\n | None -> Format.fprintf fmt \"<none>\"\n | Some h -> PS.pp_reveal fmt h\n end)\n\n module Metadata = Make_var (struct\n type t = Sc_rollup_metadata_repr.t option\n\n let initial = None\n\n let encoding = Data_encoding.option Sc_rollup_metadata_repr.encoding\n\n let name = \"metadata\"\n\n let pp fmt v =\n match v with\n | None -> Format.fprintf fmt \"<none>\"\n | Some v -> Sc_rollup_metadata_repr.pp fmt v\n end)\n\n module Current_level = Make_var (struct\n type t = Raw_level_repr.t\n\n let initial = Raw_level_repr.root\n\n let encoding = Raw_level_repr.encoding\n\n let name = \"current_level\"\n\n let pp = Raw_level_repr.pp\n end)\n\n module Message_counter = Make_var (struct\n type t = Z.t option\n\n let initial = None\n\n let encoding = Data_encoding.option Data_encoding.n\n\n let name = \"message_counter\"\n\n let pp fmt = function\n | None -> Format.fprintf fmt \"None\"\n | Some c -> Format.fprintf fmt \"Some %a\" Z.pp_print c\n end)\n\n (** Store an internal message counter. This is used to distinguish\n an unparsable external message and a internal message, which we both\n treat as no-ops. *)\n module Internal_message_counter = Make_var (struct\n type t = Z.t\n\n let initial = Z.zero\n\n let encoding = Data_encoding.n\n\n let name = \"internal_message_counter\"\n\n let pp fmt c = Z.pp_print fmt c\n end)\n\n let incr_internal_message_counter =\n let open Monad.Syntax in\n let* current_counter = Internal_message_counter.get in\n Internal_message_counter.set (Z.succ current_counter)\n\n module Next_message = Make_var (struct\n type t = string option\n\n let initial = None\n\n let encoding = Data_encoding.(option (string Plain))\n\n let name = \"next_message\"\n\n let pp fmt = function\n | None -> Format.fprintf fmt \"None\"\n | Some s -> Format.fprintf fmt \"Some %s\" s\n end)\n\n type parser_state = ParseInt | ParseVar | SkipLayout\n\n module Lexer_state = Make_var (struct\n type t = int * int\n\n let name = \"lexer_buffer\"\n\n let initial = (-1, -1)\n\n let encoding = Data_encoding.(tup2 int31 int31)\n\n let pp fmt (start, len) =\n Format.fprintf fmt \"lexer.(start = %d, len = %d)\" start len\n end)\n\n module Parser_state = Make_var (struct\n type t = parser_state\n\n let name = \"parser_state\"\n\n let initial = SkipLayout\n\n let encoding =\n Data_encoding.string_enum\n [\n (\"ParseInt\", ParseInt);\n (\"ParseVar\", ParseVar);\n (\"SkipLayout\", SkipLayout);\n ]\n\n let pp fmt = function\n | ParseInt -> Format.fprintf fmt \"Parsing int\"\n | ParseVar -> Format.fprintf fmt \"Parsing var\"\n | SkipLayout -> Format.fprintf fmt \"Skipping layout\"\n end)\n\n module Parsing_result = Make_var (struct\n type t = bool option\n\n let name = \"parsing_result\"\n\n let initial = None\n\n let encoding = Data_encoding.(option bool)\n\n let pp fmt = function\n | None -> Format.fprintf fmt \"n/a\"\n | Some true -> Format.fprintf fmt \"parsing succeeds\"\n | Some false -> Format.fprintf fmt \"parsing fails\"\n end)\n\n module Evaluation_result = Make_var (struct\n type t = bool option\n\n let name = \"evaluation_result\"\n\n let initial = None\n\n let encoding = Data_encoding.(option bool)\n\n let pp fmt = function\n | None -> Format.fprintf fmt \"n/a\"\n | Some true -> Format.fprintf fmt \"evaluation succeeds\"\n | Some false -> Format.fprintf fmt \"evaluation fails\"\n end)\n\n module Output_counter = Make_var (struct\n type t = Z.t\n\n let initial = Z.zero\n\n let name = \"output_counter\"\n\n let encoding = Data_encoding.n\n\n let pp = Z.pp_print\n end)\n\n module Output = Make_dict (struct\n type t = Sc_rollup_PVM_sig.output\n\n let name = \"output\"\n\n let encoding = Sc_rollup_PVM_sig.output_encoding\n\n let pp = Sc_rollup_PVM_sig.pp_output\n end)\n\n let pp =\n let open Monad.Syntax in\n let* status_pp = Status.pp in\n let* message_counter_pp = Message_counter.pp in\n let* next_message_pp = Next_message.pp in\n let* parsing_result_pp = Parsing_result.pp in\n let* parser_state_pp = Parser_state.pp in\n let* lexer_state_pp = Lexer_state.pp in\n let* evaluation_result_pp = Evaluation_result.pp in\n let* vars_pp = Vars.pp in\n let* output_pp = Output.pp in\n let* stack = Stack.to_list in\n let* current_tick_pp = Current_tick.pp in\n return @@ fun fmt () ->\n Format.fprintf\n fmt\n \"@[<v 0 >@;\\\n %a@;\\\n %a@;\\\n %a@;\\\n %a@;\\\n %a@;\\\n %a@;\\\n %a@;\\\n tick : %a@;\\\n vars : %a@;\\\n output :%a@;\\\n stack : %a@;\\\n @]\"\n status_pp\n ()\n message_counter_pp\n ()\n next_message_pp\n ()\n parsing_result_pp\n ()\n parser_state_pp\n ()\n lexer_state_pp\n ()\n evaluation_result_pp\n ()\n current_tick_pp\n ()\n vars_pp\n ()\n output_pp\n ()\n Format.(pp_print_list pp_print_int)\n stack\n end\n\n open State\n\n type state = State.state\n\n open Monad\n\n let initial_state ~empty =\n let m =\n let open Monad.Syntax in\n let* () = Status.set Halted in\n return ()\n in\n let open Lwt_syntax in\n let* state, _ = run m empty in\n return state\n\n let install_boot_sector state boot_sector =\n let m =\n let open Monad.Syntax in\n let* () = Boot_sector.set boot_sector in\n return ()\n in\n let open Lwt_syntax in\n let* state, _ = run m state in\n return state\n\n let state_hash state =\n let context_hash = Tree.hash state in\n Lwt.return @@ State_hash.context_hash_to_state_hash context_hash\n\n let pp state =\n let open Lwt_syntax in\n let* _, pp = Monad.run pp state in\n match pp with\n | None -> return @@ fun fmt _ -> Format.fprintf fmt \"<opaque>\"\n | Some pp ->\n let* state_hash = state_hash state in\n return (fun fmt () ->\n Format.fprintf fmt \"@[%a: %a@]\" State_hash.pp state_hash pp ())\n\n let boot =\n let open Monad.Syntax in\n let* () = Status.create in\n let* () = Next_message.create in\n let* () = Status.set Waiting_for_metadata in\n return ()\n\n let result_of ~default m state =\n let open Lwt_syntax in\n let* _, v = run m state in\n match v with None -> return default | Some v -> return v\n\n let state_of m state =\n let open Lwt_syntax in\n let* s, _ = run m state in\n return s\n\n let get_tick = result_of ~default:Sc_rollup_tick_repr.initial Current_tick.get\n\n let is_input_state_monadic =\n let open Monad.Syntax in\n let* status = Status.get in\n match status with\n | Waiting_for_input_message -> (\n let* level = Current_level.get in\n let* counter = Message_counter.get in\n match counter with\n | Some n -> return (PS.First_after (level, n))\n | None -> return PS.Initial)\n | Waiting_for_reveal -> (\n let* r = Required_reveal.get in\n match r with\n | None -> internal_error \"Internal error: Reveal invariant broken\"\n | Some reveal -> return (PS.Needs_reveal reveal))\n | Waiting_for_metadata -> return PS.(Needs_reveal Reveal_metadata)\n | Halted | Parsing | Evaluating -> return PS.No_input_required\n\n let is_input_state =\n result_of ~default:PS.No_input_required @@ is_input_state_monadic\n\n let get_status = result_of ~default:Waiting_for_input_message @@ Status.get\n\n let get_outbox outbox_level state =\n let open Lwt_syntax in\n let+ entries = result_of ~default:[] Output.entries state in\n List.filter_map\n (fun (_, msg) ->\n if Raw_level_repr.(msg.PS.outbox_level = outbox_level) then Some msg\n else None)\n entries\n\n let get_code = result_of ~default:[] @@ Code.to_list\n\n let get_parsing_result = result_of ~default:None @@ Parsing_result.get\n\n let get_stack = result_of ~default:[] @@ Stack.to_list\n\n let get_var state k = (result_of ~default:None @@ Vars.get k) state\n\n let get_evaluation_result = result_of ~default:None @@ Evaluation_result.get\n\n let get_is_stuck = result_of ~default:None @@ is_stuck\n\n let start_parsing : unit t =\n let open Monad.Syntax in\n let* () = Status.set Parsing in\n let* () = Parsing_result.set None in\n let* () = Parser_state.set SkipLayout in\n let* () = Lexer_state.set (0, 0) in\n let* () = Code.clear in\n return ()\n\n let set_inbox_message_monadic {PS.inbox_level; message_counter; payload} =\n let open Monad.Syntax in\n let* payload =\n match Sc_rollup_inbox_message_repr.deserialize payload with\n | Error _ -> return None\n | Ok (External payload) -> return (Some payload)\n | Ok (Internal (Transfer {payload; destination; _})) -> (\n let* () = incr_internal_message_counter in\n let* (metadata : Sc_rollup_metadata_repr.t option) = Metadata.get in\n match metadata with\n | Some {address; _} when Address.(destination = address) -> (\n match Micheline.root payload with\n | Bytes (_, payload) ->\n let payload = Bytes.to_string payload in\n return (Some payload)\n | _ -> return None)\n | _ -> return None)\n | Ok (Internal Start_of_level) ->\n let* () = incr_internal_message_counter in\n return None\n | Ok (Internal End_of_level) ->\n let* () = incr_internal_message_counter in\n return None\n | Ok (Internal (Info_per_level _)) ->\n let* () = incr_internal_message_counter in\n return None\n in\n match payload with\n | Some payload ->\n let* boot_sector = Boot_sector.get in\n let msg = boot_sector ^ payload in\n let* () = Current_level.set inbox_level in\n let* () = Message_counter.set (Some message_counter) in\n let* () = Next_message.set (Some msg) in\n let* () = start_parsing in\n return ()\n | None ->\n let* () = Current_level.set inbox_level in\n let* () = Message_counter.set (Some message_counter) in\n let* () = Status.set Waiting_for_input_message in\n return ()\n\n let reveal_monadic reveal_data =\n (*\n\n The inbox cursor is unchanged as the message comes from the\n outer world.\n\n We don't have to check that the data is the one we\n expected as we decided to trust the initial witness.\n\n It is the responsibility of the rollup node to check the validity\n of the [reveal_data] if it does not want to publish a wrong commitment.\n\n *)\n let open Monad.Syntax in\n match reveal_data with\n | PS.Raw_data data ->\n (* Notice that a multi-page transmission is possible by embedding\n a continuation encoded as an optional hash in [data]. *)\n let* () = Next_message.set (Some data) in\n let* () = start_parsing in\n return ()\n | PS.Metadata metadata ->\n let* () = Metadata.set (Some metadata) in\n let* () = Status.set Waiting_for_input_message in\n return ()\n | PS.Dal_page None ->\n (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/3995\n Below, we set the status to [Waiting_for_input_message] because the\n inbox is the only source of automatically fetched data.\n Once the issue above is handled (auto-fetch of Dal pages with EOL/SOL),\n the implementation should be adapted. *)\n let* () = Status.set Waiting_for_input_message in\n return ()\n | PS.Dal_page (Some data) ->\n let* () = Next_message.set (Some (Bytes.to_string data)) in\n let* () = start_parsing in\n return ()\n\n let ticked m =\n let open Monad.Syntax in\n let* tick = Current_tick.get in\n let* () = Current_tick.set (Sc_rollup_tick_repr.next tick) in\n m\n\n let set_input_monadic input =\n match input with\n | PS.Inbox_message m -> set_inbox_message_monadic m\n | PS.Reveal s -> reveal_monadic s\n\n let set_input input = set_input_monadic input |> ticked |> state_of\n\n let next_char =\n let open Monad.Syntax in\n Lexer_state.(\n let* start, len = get in\n set (start, len + 1))\n\n let no_message_to_lex () =\n internal_error \"lexer: There is no input message to lex\"\n\n let current_char =\n let open Monad.Syntax in\n let* start, len = Lexer_state.get in\n let* msg = Next_message.get in\n match msg with\n | None -> no_message_to_lex ()\n | Some s ->\n if Compare.Int.(start + len < String.length s) then\n return (Some s.[start + len])\n else return None\n\n let lexeme =\n let open Monad.Syntax in\n let* start, len = Lexer_state.get in\n let* msg = Next_message.get in\n match msg with\n | None -> no_message_to_lex ()\n | Some s ->\n let* () = Lexer_state.set (start + len, 0) in\n return (String.sub s start len)\n\n let push_int_literal =\n let open Monad.Syntax in\n let* s = lexeme in\n match int_of_string_opt s with\n | Some x -> Code.inject (IPush x)\n | None -> (* By validity of int parsing. *) assert false\n\n let push_var =\n let open Monad.Syntax in\n let* s = lexeme in\n Code.inject (IStore s)\n\n let start_evaluating : unit t =\n let open Monad.Syntax in\n let* () = Status.set Evaluating in\n let* () = Evaluation_result.set None in\n return ()\n\n let stop_parsing outcome =\n let open Monad.Syntax in\n let* () = Parsing_result.set (Some outcome) in\n start_evaluating\n\n let stop_evaluating outcome =\n let open Monad.Syntax in\n let* () = Evaluation_result.set (Some outcome) in\n Status.set Waiting_for_input_message\n\n let parse : unit t =\n let open Monad.Syntax in\n let produce_add =\n let* (_ : string) = lexeme in\n let* () = next_char in\n let* () = Code.inject IAdd in\n return ()\n in\n let produce_int =\n let* () = push_int_literal in\n let* () = Parser_state.set SkipLayout in\n return ()\n in\n let produce_var =\n let* () = push_var in\n let* () = Parser_state.set SkipLayout in\n return ()\n in\n let is_digit d = Compare.Char.(d >= '0' && d <= '9') in\n let is_letter d =\n Compare.Char.((d >= 'a' && d <= 'z') || (d >= 'A' && d <= 'Z'))\n in\n let is_identifier_char d =\n is_letter d || is_digit d\n || Compare.Char.(d = ':')\n || Compare.Char.(d = '%')\n in\n let* parser_state = Parser_state.get in\n match parser_state with\n | ParseInt -> (\n let* char = current_char in\n match char with\n | Some d when is_digit d -> next_char\n | Some '+' ->\n let* () = produce_int in\n let* () = produce_add in\n return ()\n | Some (' ' | '\\n') ->\n let* () = produce_int in\n let* () = next_char in\n return ()\n | None ->\n let* () = push_int_literal in\n stop_parsing true\n | _ -> stop_parsing false)\n | ParseVar -> (\n let* char = current_char in\n match char with\n | Some d when is_identifier_char d -> next_char\n | Some '+' ->\n let* () = produce_var in\n let* () = produce_add in\n return ()\n | Some (' ' | '\\n') ->\n let* () = produce_var in\n let* () = next_char in\n return ()\n | None ->\n let* () = push_var in\n stop_parsing true\n | _ -> stop_parsing false)\n | SkipLayout -> (\n let* char = current_char in\n match char with\n | Some (' ' | '\\n') -> next_char\n | Some '+' -> produce_add\n | Some d when is_digit d ->\n let* (_ : string) = lexeme in\n let* () = next_char in\n let* () = Parser_state.set ParseInt in\n return ()\n | Some d when is_letter d ->\n let* (_ : string) = lexeme in\n let* () = next_char in\n let* () = Parser_state.set ParseVar in\n return ()\n | None -> stop_parsing true\n | _ -> stop_parsing false)\n\n let output (destination, entrypoint) v =\n let open Monad.Syntax in\n let open Sc_rollup_outbox_message_repr in\n let* counter = Output_counter.get in\n let* () = Output_counter.set (Z.succ counter) in\n let unparsed_parameters =\n Micheline.(Int ((), Z.of_int v) |> strip_locations)\n in\n let transaction = {unparsed_parameters; destination; entrypoint} in\n let message = Atomic_transaction_batch {transactions = [transaction]} in\n let* outbox_level = Current_level.get in\n let output =\n Sc_rollup_PVM_sig.{outbox_level; message_index = counter; message}\n in\n Output.set (Z.to_string counter) output\n\n let identifies_target_contract x =\n let open Option_syntax in\n match String.split_on_char '%' x with\n | destination :: entrypoint -> (\n match Contract_hash.of_b58check_opt destination with\n | None ->\n if Compare.String.(x = \"out\") then\n return (Contract_hash.zero, Entrypoint_repr.default)\n else fail\n | Some destination ->\n let* entrypoint =\n match entrypoint with\n | [] -> return Entrypoint_repr.default\n | _ ->\n let* entrypoint =\n Non_empty_string.of_string (String.concat \"\" entrypoint)\n in\n let* entrypoint =\n Entrypoint_repr.of_annot_lax_opt entrypoint\n in\n return entrypoint\n in\n return (destination, entrypoint))\n | [] -> fail\n\n let evaluate_preimage_request hash =\n let open Monad.Syntax in\n match Sc_rollup_reveal_hash.of_b58check_opt hash with\n | None -> stop_evaluating false\n | Some hash ->\n let* () = Required_reveal.set (Some (Reveal_raw_data hash)) in\n let* () = Status.set Waiting_for_reveal in\n return ()\n\n let evaluate_dal_page_request =\n (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/3997\n - We should rather provide DAL parameters to PVM via metadata (and handle\n the case where parameters are updated on L1).\n - It's better to use EOL/SOL to request DAL pages once unique inbox MR\n is merged. *)\n (* The parameters below are those of mainnet in protocol constants, divided\n by 16. *)\n let attestation_lag = 1l in\n let page_size = 4096 / 64 in\n let slot_size = (1 lsl 20) / 64 in\n let number_of_slots = 256 / 64 in\n let number_of_pages = slot_size / page_size in\n let mk_slot_index slot_str =\n let open Option_syntax in\n let* index = Option.map Int32.to_int @@ Int32.of_string_opt slot_str in\n if Compare.Int.(index < 0 || index >= number_of_slots) then None\n else Dal_slot_repr.Index.of_int index\n in\n let mk_page_index page_str =\n let open Option_syntax in\n let* index = Option.map Int32.to_int @@ Int32.of_string_opt page_str in\n if Compare.Int.(index < 0 || index >= number_of_pages) then None\n else Some index\n in\n fun raw_page_id ->\n let mk_page_id current_lvl =\n (* Dal pages import directive is [dal:<LVL>:<SID>:<PID>]. See mli file.*)\n let open Option_syntax in\n match String.split_on_char ':' raw_page_id with\n | [lvl; slot; page] ->\n let* lvl = Int32.of_string_opt lvl in\n let* lvl = Bounded.Non_negative_int32.of_value lvl in\n let published_level = Raw_level_repr.of_int32_non_negative lvl in\n let delta = Raw_level_repr.diff current_lvl published_level in\n (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/3995\n Putting delta > 0l doesn't work here because of the way the node\n currently fetches blocks' data and calls the PVM.\n This will be changed, in particular once EOL is used to fetch DAL\n data.\n\n More generally, the whole condition below will be reworked. *)\n if\n Compare.Int32.(\n delta > 1l && delta <= Int32.mul 2l attestation_lag)\n then\n let* index = mk_slot_index slot in\n let* page_index = mk_page_index page in\n let slot_id = Dal_slot_repr.Header.{published_level; index} in\n Some Dal_slot_repr.Page.{slot_id; page_index}\n else None\n | _ -> None\n in\n let open Monad.Syntax in\n let* current_lvl = Current_level.get in\n match mk_page_id current_lvl with\n | Some page_id ->\n let* () = Required_reveal.set (Some (Request_dal_page page_id)) in\n let* () = Status.set Waiting_for_reveal in\n return ()\n | None -> stop_evaluating false\n\n let remove_prefix prefix input input_len =\n let prefix_len = String.length prefix in\n if\n Compare.Int.(input_len > prefix_len)\n && String.(equal (sub input 0 prefix_len) prefix)\n then Some (String.sub input prefix_len (input_len - prefix_len))\n else None\n\n let evaluate =\n let open Monad.Syntax in\n let* i = Code.pop in\n match i with\n | None -> stop_evaluating true\n | Some (IPush x) -> Stack.push x\n | Some (IStore x) -> (\n (* When evaluating an instruction [IStore x], we start by checking if [x]\n is a reserved directive:\n - \"hash:<HASH>\", to import a DAC data;\n - \"dal:<LVL>:<SID>:<PID>\", to request a Dal page;\n - \"out\" or \"<DESTINATION>%<ENTRYPOINT>\", to add a message in the outbox.\n Otherwise, the instruction is interpreted as a directive to store the\n top of the PVM's stack into the variable [x].\n *)\n let len = String.length x in\n match remove_prefix \"hash:\" x len with\n | Some hash -> evaluate_preimage_request hash\n | None -> (\n match remove_prefix \"dal:\" x len with\n | Some pid -> evaluate_dal_page_request pid\n | None -> (\n let* v = Stack.top in\n match v with\n | None -> stop_evaluating false\n | Some v -> (\n match identifies_target_contract x with\n | Some contract_entrypoint -> output contract_entrypoint v\n | None -> Vars.set x v))))\n | Some IAdd -> (\n let* v = Stack.pop in\n match v with\n | None -> stop_evaluating false\n | Some x -> (\n let* v = Stack.pop in\n match v with\n | None -> stop_evaluating false\n | Some y -> Stack.push (x + y)))\n\n let reboot =\n let open Monad.Syntax in\n let* () = Status.set Waiting_for_input_message in\n let* () = Stack.clear in\n let* () = Code.clear in\n return ()\n\n let eval_step =\n let open Monad.Syntax in\n let* x = is_stuck in\n match x with\n | Some _ -> reboot\n | None -> (\n let* status = Status.get in\n match status with\n | Halted -> boot\n | Waiting_for_input_message | Waiting_for_reveal | Waiting_for_metadata\n -> (\n let* msg = Next_message.get in\n match msg with\n | None -> internal_error \"An input state was not provided an input.\"\n | Some _ -> start_parsing)\n | Parsing -> parse\n | Evaluating -> evaluate)\n\n let eval state = state_of (ticked eval_step) state\n\n let step_transition input_given state =\n let open Lwt_syntax in\n let* request = is_input_state state in\n let error msg = state_of (internal_error msg) state in\n let* state =\n match (request, input_given) with\n | PS.No_input_required, None -> eval state\n | PS.No_input_required, Some _ ->\n error \"Invalid set_input: expecting no input message but got one.\"\n | (PS.Initial | PS.First_after _), Some (PS.Inbox_message _ as input)\n | ( PS.Needs_reveal (Reveal_raw_data _),\n Some (PS.Reveal (Raw_data _) as input) )\n | PS.Needs_reveal Reveal_metadata, Some (PS.Reveal (Metadata _) as input)\n | ( PS.Needs_reveal (PS.Request_dal_page _),\n Some (PS.Reveal (Dal_page _) as input) ) ->\n (* For all the cases above, the input request matches the given input, so\n we proceed by setting the input. *)\n set_input input state\n | (PS.Initial | PS.First_after _), _ ->\n error \"Invalid set_input: expecting inbox message, got a reveal.\"\n | PS.Needs_reveal (Reveal_raw_data _hash), _ ->\n error\n \"Invalid set_input: expecting a raw data reveal, got an inbox \\\n message or a reveal metadata.\"\n | PS.Needs_reveal Reveal_metadata, _ ->\n error\n \"Invalid set_input: expecting a metadata reveal, got an inbox \\\n message or a raw data reveal.\"\n | PS.Needs_reveal (PS.Request_dal_page _), _ ->\n error\n \"Invalid set_input: expecting a dal page reveal, got an inbox \\\n message or a raw data reveal.\"\n in\n return (state, request)\n\n type error += Arith_proof_verification_failed\n\n let verify_proof input_given proof =\n let open Lwt_result_syntax in\n let*! result = Context.verify_proof proof (step_transition input_given) in\n match result with\n | None -> tzfail Arith_proof_verification_failed\n | Some (_state, request) -> return request\n\n let produce_proof context input_given state =\n let open Lwt_result_syntax in\n let*! result =\n Context.produce_proof context state (step_transition input_given)\n in\n match result with\n | Some (tree_proof, _requested) -> return tree_proof\n | None -> tzfail Arith_proof_production_failed\n\n let verify_origination_proof proof boot_sector =\n let open Lwt_syntax in\n let before = Context.proof_before proof in\n if State_hash.(before <> reference_initial_state_hash) then return false\n else\n let* result =\n Context.verify_proof proof (fun state ->\n let* state = install_boot_sector state boot_sector in\n return (state, ()))\n in\n match result with None -> return false | Some (_, ()) -> return true\n\n let produce_origination_proof context boot_sector =\n let open Lwt_result_syntax in\n let*! state = initial_state ~empty:(Tree.empty context) in\n let*! result =\n Context.produce_proof context state (fun state ->\n let open Lwt_syntax in\n let* state = install_boot_sector state boot_sector in\n return (state, ()))\n in\n match result with\n | Some (proof, ()) -> return proof\n | None -> tzfail Arith_proof_production_failed\n\n (* TEMPORARY: The following definitions will be extended in a future commit. *)\n\n type output_proof = {\n output_proof : Context.proof;\n output_proof_state : hash;\n output_proof_output : PS.output;\n }\n\n let output_proof_encoding =\n let open Data_encoding in\n conv\n (fun {output_proof; output_proof_state; output_proof_output} ->\n (output_proof, output_proof_state, output_proof_output))\n (fun (output_proof, output_proof_state, output_proof_output) ->\n {output_proof; output_proof_state; output_proof_output})\n (obj3\n (req \"output_proof\" Context.proof_encoding)\n (req \"output_proof_state\" State_hash.encoding)\n (req \"output_proof_output\" PS.output_encoding))\n\n let output_of_output_proof s = s.output_proof_output\n\n let state_of_output_proof s = s.output_proof_state\n\n let output_key (output : PS.output) = Z.to_string output.message_index\n\n let has_output output tree =\n let open Lwt_syntax in\n let* equal = Output.mapped_to (output_key output) output tree in\n return (tree, equal)\n\n let verify_output_proof p =\n let open Lwt_syntax in\n let transition = has_output p.output_proof_output in\n let* result = Context.verify_proof p.output_proof transition in\n match result with None -> return false | Some _ -> return true\n\n let produce_output_proof context state output_proof_output =\n let open Lwt_result_syntax in\n let*! output_proof_state = state_hash state in\n let*! result =\n Context.produce_proof context state @@ has_output output_proof_output\n in\n match result with\n | Some (output_proof, true) ->\n return {output_proof; output_proof_state; output_proof_output}\n | Some (_, false) -> fail Arith_invalid_claim_about_outbox\n | None -> fail Arith_output_proof_production_failed\n\n let get_current_level state =\n let open Lwt_syntax in\n let* _state_, current_level = Monad.run Current_level.get state in\n return current_level\n\n module Internal_for_tests = struct\n let insert_failure state =\n let add n = Tree.add state [\"failures\"; string_of_int n] Bytes.empty in\n let open Lwt_syntax in\n let* n = Tree.length state [\"failures\"] in\n add n\n end\nend\n\nmodule Protocol_implementation = Make (struct\n module Tree = struct\n include Context.Tree\n\n type tree = Context.tree\n\n type t = Context.t\n\n type key = string list\n\n type value = bytes\n end\n\n type tree = Context.tree\n\n let hash_tree t = State_hash.context_hash_to_state_hash (Tree.hash t)\n\n type proof = Context.Proof.tree Context.Proof.t\n\n let verify_proof p f =\n let open Lwt_option_syntax in\n let*? () = Result.to_option (Context_binary_proof.check_is_binary p) in\n Lwt.map Result.to_option (Context.verify_tree_proof p f)\n\n let produce_proof _context _state _f =\n (* Can't produce proof without full context*)\n Lwt.return None\n\n let kinded_hash_to_state_hash = function\n | `Value hash | `Node hash -> State_hash.context_hash_to_state_hash hash\n\n let proof_before proof = kinded_hash_to_state_hash proof.Context.Proof.before\n\n let proof_after proof = kinded_hash_to_state_hash proof.Context.Proof.after\n\n let proof_encoding = Context.Proof_encoding.V2.Tree2.tree_proof_encoding\nend)\n" ;
} ;
{ name = "Sc_rollup_wasm" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule V2_0_0 : sig\n (** This module provides Proof-Generating Virtual Machine (PVM) running\n WebAssembly (version 2.0.0). *)\n\n module type S = sig\n include Sc_rollup_PVM_sig.S\n\n (** [parse_boot_sector s] builds a boot sector from its human\n writable description. *)\n val parse_boot_sector : string -> string option\n\n (** [pp_boot_sector fmt s] prints a human readable representation of\n a boot sector. *)\n val pp_boot_sector : Format.formatter -> string -> unit\n\n (* Required by L2 node: *)\n\n (** [get_tick state] gets the total tick counter for the given PVM state. *)\n val get_tick : state -> Sc_rollup_tick_repr.t Lwt.t\n\n (** PVM status *)\n type status =\n | Computing\n | Waiting_for_input_message\n | Waiting_for_reveal of Sc_rollup_PVM_sig.reveal\n\n (** [get_status state] gives you the current execution status for the PVM. *)\n val get_status : state -> status Lwt.t\n\n (** [get_outbox outbox_level state] returns the outbox in [state]\n for a given [outbox_level]. *)\n val get_outbox :\n Raw_level_repr.t -> state -> Sc_rollup_PVM_sig.output list Lwt.t\n end\n\n module type P = sig\n module Tree :\n Context.TREE with type key = string list and type value = bytes\n\n type tree = Tree.tree\n\n type proof\n\n val proof_encoding : proof Data_encoding.t\n\n val proof_before : proof -> Sc_rollup_repr.State_hash.t\n\n val proof_after : proof -> Sc_rollup_repr.State_hash.t\n\n val verify_proof :\n proof -> (tree -> (tree * 'a) Lwt.t) -> (tree * 'a) option Lwt.t\n\n val produce_proof :\n Tree.t -> tree -> (tree -> (tree * 'a) Lwt.t) -> (proof * 'a) option Lwt.t\n end\n\n module type Make_wasm = module type of Wasm_2_0_0.Make\n\n (** Build a WebAssembly PVM using the given proof-supporting context. *)\n module Make (Lib_scoru_Wasm : Make_wasm) (Context : P) :\n S\n with type context = Context.Tree.t\n and type state = Context.tree\n and type proof = Context.proof\n\n (** This PVM is used for verification in the Protocol. [produce_proof] always returns [None]. *)\n module Protocol_implementation :\n S\n with type context = Context.t\n and type state = Context.tree\n and type proof = Context.Proof.tree Context.Proof.t\n\n (** This is the state hash of reference that both the prover of the\n node and the verifier of the protocol {!Protocol_implementation}\n have to agree on (if they do, it means they are using the same\n tree structure). *)\n val reference_initial_state_hash : Sc_rollup_repr.State_hash.t\n\n (** Number of ticks between snapshotable states, chosen low enough\n to maintain refutability.\n\n {b Warning:} This value is used to specialize the dissection\n predicate of the WASM PVM. Do not change it without a migration\n plan for already originated smart rollups.\n\n Depends on\n - speed (tick/s) of node in slow mode (from benchmark, 6000000 tick/s)\n - the number of ticks in a commitment ({!Int64.max_int},\n as per Number_of_ticks.max_value)\n\n see #3590 for more pointers *)\n val ticks_per_snapshot : Z.t\n\n (* The number of outboxes to keep, which is for a period of two weeks. For a\n block time of 30 seconds, this equals to 2 * 60 * 24 * 14 = 40_320\n blocks. *)\n val outbox_validity_period : int32\n\n (* Maximum number of outbox messages per level.\n\n Equals to {Constants_parametric_repr.max_outbox_messages_per_level}. *)\n val outbox_message_limit : Z.t\n\n (** The hash requested by the WASM PVM if it cannot decode the input\n provided by the WASM kernel, that is, if the bytes value cannot\n be decoded with {!Sc_rollup_reveal_hash.encoding}. *)\n val well_known_reveal_hash : Sc_rollup_reveal_hash.t\n\n (** The preimage of {!well_known_reveal_hash}. *)\n val well_known_reveal_preimage : string\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error += WASM_proof_verification_failed\n\ntype error += WASM_proof_production_failed\n\ntype error += WASM_output_proof_production_failed\n\ntype error += WASM_invalid_claim_about_outbox\n\ntype error += WASM_invalid_dissection_distribution\n\nlet () =\n let open Data_encoding in\n let msg = \"Invalid claim about outbox\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_wasm_invalid_claim_about_outbox\"\n ~title:msg\n ~pp:(fun fmt () -> Format.pp_print_string fmt msg)\n ~description:msg\n unit\n (function WASM_invalid_claim_about_outbox -> Some () | _ -> None)\n (fun () -> WASM_invalid_claim_about_outbox) ;\n let msg = \"Output proof production failed\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_wasm_output_proof_production_failed\"\n ~title:msg\n ~pp:(fun fmt () -> Format.fprintf fmt \"%s\" msg)\n ~description:msg\n unit\n (function WASM_output_proof_production_failed -> Some () | _ -> None)\n (fun () -> WASM_output_proof_production_failed) ;\n let msg = \"Proof production failed\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_wasm_proof_production_failed\"\n ~title:msg\n ~pp:(fun fmt () -> Format.fprintf fmt \"%s\" msg)\n ~description:msg\n unit\n (function WASM_proof_production_failed -> Some () | _ -> None)\n (fun () -> WASM_proof_production_failed) ;\n let msg =\n \"Invalid dissection distribution: not all ticks are a multiplier of the \\\n maximum number of ticks of a snapshot\"\n in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_wasm_invalid_dissection_distribution\"\n ~title:msg\n ~pp:(fun fmt () -> Format.fprintf fmt \"%s\" msg)\n ~description:msg\n unit\n (function WASM_invalid_dissection_distribution -> Some () | _ -> None)\n (fun () -> WASM_invalid_dissection_distribution)\n\nmodule V2_0_0 = struct\n let ticks_per_snapshot = Z.of_int64 11_000_000_000L\n\n let outbox_validity_period = Int32.of_int 80_640\n\n let outbox_message_limit = Z.of_int 100\n\n let well_known_reveal_preimage = \"\"\n\n let well_known_reveal_hash =\n Sc_rollup_reveal_hash.hash_string\n ~scheme:Blake2B\n [well_known_reveal_preimage]\n\n (*\n This is the state hash of reference that both the prover of the\n node and the verifier of the protocol {!Protocol_implementation}\n have to agree on (if they do, it means they are using the same\n tree structure).\n\n We have to hard-code this value because the Wasm PVM uses Irmin as\n its Merkle proof verification backend, and the economic protocol\n cannot create an empty Irmin context. Such a context is required to\n create an empty tree, itself required to create the initial state of\n the Wasm PVM.\n\n Utlimately, the value of this constant is decided by the prover of\n reference (the only need is for it to be compatible with\n {!Protocol_implementation}.)\n\n Its value is the result of the following snippet\n\n {|\n let*! state = Prover.initial_state context in\n Prover.state_hash state\n |}\n *)\n let reference_initial_state_hash =\n Sc_rollup_repr.State_hash.of_b58check_exn\n \"srs11XQCynQfGtuUr4c47rAoazGeTfC33R5FmimBKbnMrWwntHURX1\"\n\n open Sc_rollup_repr\n module PS = Sc_rollup_PVM_sig\n\n module type TreeS =\n Context.TREE with type key = string list and type value = bytes\n\n module type Make_wasm = module type of Wasm_2_0_0.Make\n\n module type P = sig\n module Tree : TreeS\n\n type tree = Tree.tree\n\n type proof\n\n val proof_encoding : proof Data_encoding.t\n\n val proof_before : proof -> State_hash.t\n\n val proof_after : proof -> State_hash.t\n\n val verify_proof :\n proof -> (tree -> (tree * 'a) Lwt.t) -> (tree * 'a) option Lwt.t\n\n val produce_proof :\n Tree.t -> tree -> (tree -> (tree * 'a) Lwt.t) -> (proof * 'a) option Lwt.t\n end\n\n module type S = sig\n include Sc_rollup_PVM_sig.S\n\n val parse_boot_sector : string -> string option\n\n val pp_boot_sector : Format.formatter -> string -> unit\n\n (** [get_tick state] gets the total tick counter for the given PVM state. *)\n val get_tick : state -> Sc_rollup_tick_repr.t Lwt.t\n\n (** PVM status *)\n type status =\n | Computing\n | Waiting_for_input_message\n | Waiting_for_reveal of Sc_rollup_PVM_sig.reveal\n\n (** [get_status state] gives you the current execution status for the PVM. *)\n val get_status : state -> status Lwt.t\n\n val get_outbox :\n Raw_level_repr.t -> state -> Sc_rollup_PVM_sig.output list Lwt.t\n end\n\n (* [Make (Make_backend) (Context)] creates a PVM.\n\n The Make_backend is a functor that creates the backend of the PVM.\n The Conext provides the tree and the proof types.\n *)\n module Make (Make_backend : Make_wasm) (Context : P) :\n S\n with type context = Context.Tree.t\n and type state = Context.tree\n and type proof = Context.proof = struct\n module Tree = Context.Tree\n\n type context = Context.Tree.t\n\n type hash = State_hash.t\n\n type proof = Context.proof\n\n let proof_encoding = Context.proof_encoding\n\n let proof_start_state proof = Context.proof_before proof\n\n let proof_stop_state proof = Context.proof_after proof\n\n let parse_boot_sector s = Hex.to_string @@ `Hex s\n\n let pp_boot_sector fmt s = Format.fprintf fmt \"%s\" s\n\n type tree = Tree.tree\n\n type status =\n | Computing\n | Waiting_for_input_message\n | Waiting_for_reveal of Sc_rollup_PVM_sig.reveal\n\n module State = struct\n type state = tree\n\n module Monad : sig\n type 'a t\n\n val run : 'a t -> state -> (state * 'a) Lwt.t\n\n val return : 'a -> 'a t\n\n module Syntax : sig\n val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t\n end\n\n val get : tree t\n\n val set : tree -> unit t\n\n val lift : 'a Lwt.t -> 'a t\n end = struct\n type 'a t = state -> (state * 'a) Lwt.t\n\n let return x state = Lwt.return (state, x)\n\n let bind m f state =\n let open Lwt_syntax in\n let* state, res = m state in\n f res state\n\n module Syntax = struct\n let ( let* ) = bind\n end\n\n let run m state = m state\n\n let get s = Lwt.return (s, s)\n\n let set s _ = Lwt.return (s, ())\n\n let lift m s = Lwt.map (fun r -> (s, r)) m\n end\n end\n\n type state = State.state\n\n module WASM_machine = Make_backend (Tree)\n open State\n\n let pp _state =\n Lwt.return @@ fun fmt () -> Format.pp_print_string fmt \"<wasm-state>\"\n\n open Monad\n\n let initial_state ~empty = WASM_machine.initial_state empty\n\n let install_boot_sector state boot_sector =\n WASM_machine.install_boot_sector\n ~ticks_per_snapshot\n ~outbox_validity_period\n ~outbox_message_limit\n boot_sector\n state\n\n let state_hash state =\n let context_hash = Tree.hash state in\n Lwt.return @@ State_hash.context_hash_to_state_hash context_hash\n\n let result_of m state =\n let open Lwt_syntax in\n let* _, v = run m state in\n return v\n\n let state_of m state =\n let open Lwt_syntax in\n let* s, _ = run m state in\n return s\n\n let get_tick : Sc_rollup_tick_repr.t Monad.t =\n let open Monad.Syntax in\n let* s = get in\n let* info = lift (WASM_machine.get_info s) in\n return @@ Sc_rollup_tick_repr.of_z info.current_tick\n\n let get_tick : state -> Sc_rollup_tick_repr.t Lwt.t = result_of get_tick\n\n let get_status : status Monad.t =\n let open Monad.Syntax in\n let open Sc_rollup_PVM_sig in\n let* s = get in\n let* info = lift (WASM_machine.get_info s) in\n return\n @@\n match info.input_request with\n | No_input_required -> Computing\n | Input_required -> Waiting_for_input_message\n | Reveal_required (Wasm_2_0_0.Reveal_raw_data hash) -> (\n match\n Data_encoding.Binary.of_string_opt\n Sc_rollup_reveal_hash.encoding\n hash\n with\n | Some hash -> Waiting_for_reveal (Reveal_raw_data hash)\n | None ->\n (* In case of an invalid hash, the rollup is\n blocked. Any commitment will be invalid. *)\n Waiting_for_reveal (Reveal_raw_data well_known_reveal_hash))\n | Reveal_required Wasm_2_0_0.Reveal_metadata ->\n Waiting_for_reveal Reveal_metadata\n\n let get_last_message_read : _ Monad.t =\n let open Monad.Syntax in\n let* s = get in\n let* info = lift (WASM_machine.get_info s) in\n return\n @@\n match info.last_input_read with\n | Some {inbox_level; message_counter} ->\n let inbox_level = Raw_level_repr.of_int32_non_negative inbox_level in\n Some (inbox_level, message_counter)\n | _ -> None\n\n let is_input_state =\n let open Monad.Syntax in\n let* status = get_status in\n match status with\n | Waiting_for_input_message -> (\n let* last_read = get_last_message_read in\n match last_read with\n | Some (level, n) -> return (PS.First_after (level, n))\n | None -> return PS.Initial)\n | Computing -> return PS.No_input_required\n | Waiting_for_reveal reveal -> return (PS.Needs_reveal reveal)\n\n let is_input_state = result_of is_input_state\n\n let get_status : state -> status Lwt.t = result_of get_status\n\n let get_outbox outbox_level state =\n let outbox_level_int32 =\n Raw_level_repr.to_int32_non_negative outbox_level\n in\n let open Lwt_syntax in\n let rec aux outbox message_index =\n let output =\n Wasm_2_0_0.{outbox_level = outbox_level_int32; message_index}\n in\n let* res = WASM_machine.get_output output state in\n match res with\n | None -> return (List.rev outbox)\n | Some msg -> (\n let serialized =\n Sc_rollup_outbox_message_repr.unsafe_of_string msg\n in\n match Sc_rollup_outbox_message_repr.deserialize serialized with\n | Error _ ->\n (* The [write_output] host function does not guarantee that the contents\n of the returned output is a valid encoding of an outbox message.\n We choose to ignore such messages. An alternative choice would be to\n craft an output with a payload witnessing the illformedness of the\n output produced by the kernel. *)\n (aux [@ocaml.tailcall]) outbox (Z.succ message_index)\n | Ok message ->\n let output = PS.{outbox_level; message_index; message} in\n (aux [@ocaml.tailcall])\n (output :: outbox)\n (Z.succ message_index))\n in\n aux [] Z.zero\n\n let set_input_state input =\n let open Monad.Syntax in\n match input with\n | PS.Inbox_message input ->\n let open PS in\n let {inbox_level; message_counter; payload} = input in\n let* s = get in\n let* s =\n lift\n (WASM_machine.set_input_step\n {\n inbox_level = Raw_level_repr.to_int32_non_negative inbox_level;\n message_counter;\n }\n (payload :> string)\n s)\n in\n set s\n | PS.Reveal (PS.Raw_data data) ->\n let* s = get in\n let* s = lift (WASM_machine.reveal_step (Bytes.of_string data) s) in\n set s\n | PS.Reveal (PS.Metadata metadata) ->\n let metadata_bytes =\n Data_encoding.Binary.to_bytes_exn\n Sc_rollup_metadata_repr.encoding\n metadata\n in\n let* s = get in\n let* s = lift (WASM_machine.reveal_step metadata_bytes s) in\n set s\n | PS.Reveal (PS.Dal_page _content_opt) ->\n (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/3927.\n Handle DAL pages in wasm PVM. *)\n assert false\n\n let set_input input = state_of @@ set_input_state input\n\n let eval_step =\n let open Monad.Syntax in\n let* s = get in\n let* s = lift (WASM_machine.compute_step s) in\n set s\n\n let eval state = state_of eval_step state\n\n let step_transition input_given state =\n let open Lwt_syntax in\n let* request = is_input_state state in\n let* state =\n match request with\n | PS.No_input_required -> eval state\n | _ -> (\n match input_given with\n | Some input -> set_input input state\n | None -> return state)\n in\n return (state, request)\n\n let verify_proof input_given proof =\n let open Lwt_result_syntax in\n let*! result = Context.verify_proof proof (step_transition input_given) in\n match result with\n | None -> tzfail WASM_proof_verification_failed\n | Some (_state, request) -> return request\n\n let produce_proof context input_given state =\n let open Lwt_result_syntax in\n let*! result =\n Context.produce_proof context state (step_transition input_given)\n in\n match result with\n | Some (tree_proof, _requested) -> return tree_proof\n | None -> tzfail WASM_proof_production_failed\n\n let verify_origination_proof proof boot_sector =\n let open Lwt_syntax in\n let before = Context.proof_before proof in\n if State_hash.(before <> reference_initial_state_hash) then return false\n else\n let* result =\n Context.verify_proof proof (fun state ->\n let* state = install_boot_sector state boot_sector in\n return (state, ()))\n in\n match result with None -> return false | Some (_, ()) -> return true\n\n let produce_origination_proof context boot_sector =\n let open Lwt_result_syntax in\n let*! state = initial_state ~empty:(Tree.empty context) in\n let*! result =\n Context.produce_proof context state (fun state ->\n let open Lwt_syntax in\n let* state = install_boot_sector state boot_sector in\n return (state, ()))\n in\n match result with\n | Some (tree_proof, ()) -> return tree_proof\n | None -> tzfail WASM_proof_production_failed\n\n type output_proof = {\n output_proof : Context.proof;\n output_proof_state : hash;\n output_proof_output : PS.output;\n }\n\n let output_proof_encoding =\n let open Data_encoding in\n conv\n (fun {output_proof; output_proof_state; output_proof_output} ->\n (output_proof, output_proof_state, output_proof_output))\n (fun (output_proof, output_proof_state, output_proof_output) ->\n {output_proof; output_proof_state; output_proof_output})\n (obj3\n (req \"output_proof\" Context.proof_encoding)\n (req \"output_proof_state\" State_hash.encoding)\n (req \"output_proof_output\" PS.output_encoding))\n\n let output_of_output_proof s = s.output_proof_output\n\n let state_of_output_proof s = s.output_proof_state\n\n let has_output : PS.output -> bool Monad.t = function\n | {outbox_level; message_index; message} -> (\n let open Monad.Syntax in\n let* s = get in\n let* result =\n lift\n (WASM_machine.get_output\n {\n outbox_level =\n Raw_level_repr.to_int32_non_negative outbox_level;\n message_index;\n }\n s)\n in\n let message_encoded =\n Data_encoding.Binary.to_string_exn\n Sc_rollup_outbox_message_repr.encoding\n message\n in\n return\n @@\n match result with\n | Some result -> Compare.String.(result = message_encoded)\n | None -> false)\n\n let verify_output_proof p =\n let open Lwt_syntax in\n let transition = run @@ has_output p.output_proof_output in\n let* result = Context.verify_proof p.output_proof transition in\n match result with None -> return false | Some _ -> return true\n\n let produce_output_proof context state output_proof_output =\n let open Lwt_result_syntax in\n let*! output_proof_state = state_hash state in\n let*! result =\n Context.produce_proof context state\n @@ run\n @@ has_output output_proof_output\n in\n match result with\n | Some (output_proof, true) ->\n return {output_proof; output_proof_state; output_proof_output}\n | Some (_, false) -> fail WASM_invalid_claim_about_outbox\n | None -> fail WASM_output_proof_production_failed\n\n let check_sections_number ~default_number_of_sections ~number_of_sections\n ~dist =\n let open Sc_rollup_dissection_chunk_repr in\n let is_stop_chunk_aligned =\n Compare.Z.(Z.rem dist ticks_per_snapshot = Z.zero)\n in\n let max_number_of_sections = Z.(div dist ticks_per_snapshot) in\n let expected =\n Compare.Z.min\n (Z.of_int default_number_of_sections)\n (if is_stop_chunk_aligned then max_number_of_sections\n else Z.succ max_number_of_sections)\n in\n let given = Z.of_int number_of_sections in\n error_unless\n Compare.Z.(given = expected)\n (Dissection_number_of_sections_mismatch {given; expected})\n\n let check_dissection ~default_number_of_sections ~start_chunk ~stop_chunk\n dissection =\n let open Result_syntax in\n let open Sc_rollup_dissection_chunk_repr in\n let dist =\n Sc_rollup_tick_repr.distance start_chunk.tick stop_chunk.tick\n in\n (*\n We fall back to the default dissection check when the\n [kernel_run] culprit has been found and is being dissected.\n\n This condition will also be met if the PVM is stuck (because\n it is unlikely that [ticks_per_snapshot] messages can be\n posted in a commitment period), which is OKay because the Fast\n Execution cannot be leveraged in that case, which means the\n ad-hoc dissection predicate would not provide any speed up.\n *)\n if Compare.Z.(dist <= ticks_per_snapshot) then\n default_check\n ~section_maximum_size:Z.(div dist (Z.of_int 2))\n ~check_sections_number:default_check_sections_number\n ~default_number_of_sections\n ~start_chunk\n ~stop_chunk\n dissection\n else\n (*\n There are enough ticks to consider that at least one call\n to [kernel_run] is involved.\n\n We now need to consider two cases: either [stop_chunk] is a\n multiple of [ticks_per_snapshot] (the PVM is not stuck), or\n it is not (the PVM has been stuck during the processing\n of one of the ticks of the dissection).\n\n For the latter case, we want to validate a dissection if\n\n 1. Every complete [kernel_run] invocations are dissected\n as normal in the n-1 first chunks, and\n 2. The final section contains all the ticks of the\n interrupted [kernel_run].\n *)\n let is_stop_chunk_aligned =\n Compare.Z.(Z.rem dist ticks_per_snapshot = Z.zero)\n in\n (*\n We keep the same dissection predicate as the default\n dissection that a given section cannot be more than half of\n the \226\128\156full distance\226\128\157, but we only consider the complete\n calls to [kernel_run] in the \226\128\156full distance\226\128\157. The remainder\n ticks will be put in the very last section.\n *)\n let considered_dist =\n if is_stop_chunk_aligned then dist\n else\n let last_valid_stop_tick =\n Sc_rollup_tick_repr.of_z\n Z.(\n mul\n (div\n (Sc_rollup_tick_repr.to_z stop_chunk.tick)\n ticks_per_snapshot)\n ticks_per_snapshot)\n in\n Sc_rollup_tick_repr.(distance start_chunk.tick last_valid_stop_tick)\n in\n (*\n There is one last corner case to consider: if the stuck\n state happens in the second [kernel_run] of the period.\n\n In this case, the considered distance is equal to the\n snapshot size, and divided this value by two means the\n maximum size of a section becomes 0.\n\n So we keep that a section length is at least\n [ticks_per_snapshot].\n *)\n let section_maximum_size =\n Z.max ticks_per_snapshot (Z.div considered_dist (Z.of_int 2))\n in\n let* () =\n default_check\n ~section_maximum_size\n ~check_sections_number\n ~default_number_of_sections\n ~start_chunk\n ~stop_chunk\n dissection\n in\n error_unless\n (List.for_all\n (fun chunk ->\n let open Sc_rollup_tick_repr in\n Z.(\n equal (rem (to_z chunk.tick) ticks_per_snapshot) zero\n || Sc_rollup_tick_repr.equal start_chunk.tick chunk.tick\n || Sc_rollup_tick_repr.equal stop_chunk.tick chunk.tick))\n dissection)\n WASM_invalid_dissection_distribution\n\n let get_current_level state =\n let open Lwt_syntax in\n let+ res = result_of get_last_message_read state in\n Option.map fst res\n\n module Internal_for_tests = struct\n let insert_failure state =\n let add n = Tree.add state [\"failures\"; string_of_int n] Bytes.empty in\n let open Lwt_syntax in\n let* n = Tree.length state [\"failures\"] in\n add n\n end\n end\n\n module Protocol_implementation =\n Make\n (Wasm_2_0_0.Make)\n (struct\n module Tree = struct\n include Context.Tree\n\n type tree = Context.tree\n\n type t = Context.t\n\n type key = string list\n\n type value = bytes\n end\n\n type tree = Context.tree\n\n type proof = Context.Proof.tree Context.Proof.t\n\n let verify_proof p f =\n let open Lwt_option_syntax in\n let*? () =\n Result.to_option (Context_binary_proof.check_is_binary p)\n in\n Lwt.map Result.to_option (Context.verify_tree_proof p f)\n\n let produce_proof _context _state _f =\n (* Can't produce proof without full context*)\n Lwt.return None\n\n let kinded_hash_to_state_hash = function\n | `Value hash | `Node hash ->\n State_hash.context_hash_to_state_hash hash\n\n let proof_before proof =\n kinded_hash_to_state_hash proof.Context.Proof.before\n\n let proof_after proof =\n kinded_hash_to_state_hash proof.Context.Proof.after\n\n let proof_encoding = Context.Proof_encoding.V2.Tree2.tree_proof_encoding\n end)\nend\n" ;
} ;
{ name = "Sc_rollups" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Here is the list of PVMs available in this protocol. *)\n\nmodule PVM : sig\n type boot_sector = string\n\n module type S = sig\n val parse_boot_sector : string -> boot_sector option\n\n val pp_boot_sector : Format.formatter -> boot_sector -> unit\n\n include Sc_rollup_PVM_sig.S\n end\n\n type ('state, 'proof, 'output) implementation =\n (module S\n with type state = 'state\n and type proof = 'proof\n and type output_proof = 'output)\n\n type t = Packed : ('state, 'proof, 'output) implementation -> t [@@unboxed]\nend\n\n(** A smart contract rollup has a kind, which assigns meaning to\n rollup operations. *)\nmodule Kind : sig\n (**\n\n The list of available rollup kinds.\n\n This list must only be appended for backward compatibility.\n *)\n type t = Example_arith | Wasm_2_0_0\n\n val encoding : t Data_encoding.t\n\n val equal : t -> t -> bool\n\n (** [pvm_of kind] returns the [PVM] of the given [kind]. *)\n val pvm_of : t -> PVM.t\n\n (** [all] returns all implemented PVM. *)\n val all : t list\n\n val of_string : string -> t option\n\n val to_string : t -> string\n\n val pp : Format.formatter -> t -> unit\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule PVM = struct\n type boot_sector = string\n\n module type S = sig\n val parse_boot_sector : string -> boot_sector option\n\n val pp_boot_sector : Format.formatter -> boot_sector -> unit\n\n include Sc_rollup_PVM_sig.S\n end\n\n type ('state, 'proof, 'output) implementation =\n (module S\n with type state = 'state\n and type proof = 'proof\n and type output_proof = 'output)\n\n type t = Packed : ('state, 'proof, 'output) implementation -> t [@@unboxed]\nend\n\nmodule Kind = struct\n (*\n Each time we add a data constructor to [t], we also need:\n - to extend [Sc_rollups.all] with this new constructor ;\n - to update [Sc_rollups.of_name] and [encoding] ;\n - to update [Sc_rollups.wrapped_proof] and [wrapped_proof_encoding].\n\n *)\n type t = Example_arith | Wasm_2_0_0\n\n let all = [Example_arith; Wasm_2_0_0]\n\n let to_string = function\n | Example_arith -> \"arith\"\n | Wasm_2_0_0 -> \"wasm_2_0_0\"\n\n let of_string = function\n | \"arith\" -> Some Example_arith\n | \"wasm_2_0_0\" -> Some Wasm_2_0_0\n | _ -> None\n\n let encoding =\n Data_encoding.string_enum @@ List.map (fun k -> (to_string k, k)) all\n\n let pp fmt = function\n | Example_arith -> Format.pp_print_string fmt \"arith\"\n | Wasm_2_0_0 -> Format.pp_print_string fmt \"wasm_2_0_0\"\n\n let equal x y =\n match (x, y) with\n | Example_arith, Example_arith -> true\n | Wasm_2_0_0, Wasm_2_0_0 -> true\n | _ -> false\n\n let example_arith_pvm =\n PVM.Packed (module Sc_rollup_arith.Protocol_implementation)\n\n let wasm_2_0_0_pvm =\n PVM.Packed (module Sc_rollup_wasm.V2_0_0.Protocol_implementation)\n\n let pvm_of = function\n | Example_arith -> example_arith_pvm\n | Wasm_2_0_0 -> wasm_2_0_0_pvm\nend\n" ;
} ;
{ name = "Sc_rollup_data_version_sig" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** The values are versioned, to let the possibility to modify\n the values in future iterations of the protocol.\n\n We allow the possibility to modify the values by introducing\n a {!versioned} value that is the only values written in the storage.\n \n In future versions, the versioning is supposed to let us reinterpret old\n stored values within the new protocol implementation. That is, each\n access to the storage will transform old stored values to the\n current version.\n*)\n\nmodule type S = sig\n type t\n\n type versioned\n\n val versioned_encoding : versioned Data_encoding.t\n\n val of_versioned : versioned -> t\n\n val to_versioned : t -> versioned\nend\n" ;
} ;
{ name = "Sc_rollup_inbox_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error += Inbox_proof_error of string\n\ntype error += Inbox_level_reached_messages_limit\n\n(** Merkelizing inbox for smart-contract rollups.\n\n {1 Overview}\n\n The inbox of a smart-contract rollup denotes the incoming messages\n of the rollup. This inbox is the source of truth about what\n operations are being published and have an effect on the rollup\n state. As such, the inbox completely determines the state of the\n rollup. Hence, if two claims disagree about the state of the\n rollup, there are only two possibilities: either these two claims\n correspond to two distinct interpretations of the same inbox ; or,\n these two claims differ on their views about the contents of the\n inbox itself. {!Sc_rollup_PVM_sig} is meant to arbitrate the first\n kind of conflicts while {!Sc_rollup_inbox} focuses on the second\n kind of conflicts.\n\n {1 Inbox messages}\n\n A message is a chunk of bytes. Messages are indexed using natural\n numbers and the level they are introduced.\n\n A message is said to be *consumed* when its processing has been\n cemented, that is, when no refutation about its insertion can\n happen anymore because the commitment that describes the effect of\n this message on the state is cemented. A message is said to be\n *available* (for dispute) if it is not consumed.\n\n A message processed by the rollup can be consumed or available. A\n message unprocessed by the rollup is always available.\n\n The number of messages in an inbox level is bounded by\n {!Constants_repr.sc_rollup_max_number_of_messages_per_level}\n When a level inbox reaches the maximum number of messages in the inbox level,\n the inbox is said to be full and cannot accept more messages at this level.\n This limitation is meant to ensure that Merkle proofs about the inbox\n contents have a bounded size. (See next section.)\n\n {1 Merkelization of the inbox}\n\n As for the state of the {!Sc_rollup_PVM_sig}, the layer 1 does not\n have to store the entire inbox but only a compressed form\n (typically a low number of hashes) that witnesses its contents, so\n that the protocol can check the validity of a proof about its contents.\n This saves space in the context of the layer 1 and is sufficient for the\n layer 1 to provide a source of truth about the contents of the\n inbox at the current level.\n\n {1 A level-indexed chain of inboxes}\n\n By design, inboxes are logically indexed by Tezos levels. This is\n required to have a simple way to decide if two commitments are in\n conflict. (See {!Sc_rollup_storage}.)\n\n A commitment included in the block at level L describes the effect\n of the messages of the inboxes with a level between a starting\n level L_0 and a stopping level L_1, both strictly inferior to\n L. The level L_0 must be the inbox level of its parent\n commitment.\n\n To be valid, a commitment needs to prove that it is reading\n messages from an inbox which is consistent with the inbox at level\n L stored in the layer 1 context. So, it should be possible at any\n time to build a proof that a given inbox is a previous version at\n level L_1 of the inbox found at level L: these are called inclusion\n proofs.\n\n {1 Clients}\n\n This module is meant to be used both by the protocol and by the\n rollup node in order to maintain consistent inboxes on both sides.\n These two clients slightly differ on the amount of information they\n store about the inbox.\n\n On the one hand, to reduce the space consumption of rollups on the\n chain storage, the protocol only stores metadata about the\n inbox. The messages' hash of the current level are kept in memory during\n block validation only (See {!Raw_context.Sc_rollup_in_memory_inbox}).\n By contrast, the messages of the previous levels are not kept in\n the context at all. They can be retrieved from the chain\n history though. However, being absent from the context, they are\n not accessible to the protocol.\n\n On the other hand, the rollup node must keep a more precise inbox\n to be able to produce Merkle proofs about the content of specific\n messages, at least during the refutation period.\n\n To cope with the discrepancy of requirements in terms of inbox\n storage while preserving a consistent Merkelization\n between the protocol and the rollup node, this module exposes the\n functions used to merkelize the inbox with an history (See\n {!History_bounded_repr.t}) as parameters to remember.\n\n*)\n\nmodule Hash : S.HASH\n\nmodule Skip_list : Skip_list_repr.S\n\nmodule V1 : sig\n type level_proof = {\n hash : Sc_rollup_inbox_merkelized_payload_hashes_repr.Hash.t;\n level : Raw_level_repr.t;\n }\n\n (** A [history_proof] is a [Skip_list.cell] that stores multiple\n hashes. [Skip_list.content history_proof] gives the hash of this cell,\n while [Skip_list.back_pointers history_proof] is an array of hashes of\n earlier [history_proof]s in the inbox.\n\n On the one hand, we think of this type as representing the whole\n Merkle structure of an inbox at a given level---it is the part of\n {!t} above that can actually be used to prove things (it cannot be\n forged by a malicious node because it much match the hash stored by\n the L1).\n\n On the other hand, we think of this type as representing a single\n proof-step back through the history of the inbox; given a hash that\n appears at some point later in the inbox this type proves that that\n hash points to this particular combination of a level tree and\n further back-pointers.\n\n In terms of size, this type is a small set of hashes; one for the\n current level tree and `O(log2(ix))` in the back-pointers, where\n [ix] is the index of the cell in the skip list. That is, [ix] is the\n number of non-empty levels between now and the origination level of\n the rollup.\n *)\n type history_proof = (level_proof, Hash.t) Skip_list.cell\n\n (** The type of the inbox for a smart-contract rollup as stored\n by the protocol in the context. Values that inhabit this type\n only act as fingerprint for inboxes and contain:\n - [level] : the inbox level ;\n - [old_levels_messages] : a witness of the inbox history.\n *)\n type t = {level : Raw_level_repr.t; old_levels_messages : history_proof}\n\n val pp : Format.formatter -> t -> unit\n\n val equal : t -> t -> bool\n\n val hash : t -> Hash.t\n\n val encoding : t Data_encoding.t\n\n (** [inbox_level inbox] returns the maximum level of message insertion in\n [inbox] or its initial level. *)\n val inbox_level : t -> Raw_level_repr.t\n\n (** A [History.t] is basically a lookup table of {!history_proof}s. We\n need this if we want to produce inbox proofs because it allows us\n to dereference the 'pointer' hashes in any of the\n [history_proof]s. This [deref] function is passed to\n [Skip_list.back_path] or [Skip_list.search] to allow these\n functions to construct valid paths back through the skip list.\n\n A subtlety of this [history] type is that it is customizable\n depending on how much of the inbox history you actually want to\n remember, using the [capacity] parameter. In the L1 we use this with\n [capacity] set to zero, which makes it immediately forget an old\n level as soon as we move to the next. By contrast, the rollup node\n uses a history that is sufficiently large to be able to take part\n in all potential refutation games occurring during the challenge\n period. *)\n module History :\n Bounded_history_repr.S with type key = Hash.t and type value = history_proof\n\n val pp_history_proof : Format.formatter -> history_proof -> unit\n\n val history_proof_encoding : history_proof Data_encoding.t\n\n val equal_history_proof : history_proof -> history_proof -> bool\n\n (** [old_levels_messages inbox] returns the latest skip list cell of the inbox\n history that is not up to change (i.e. not the current level tree). *)\n val old_levels_messages : t -> history_proof\n\n (** [current_witness inbox] returns the current witness of the inbox, i.e. the\n merkelized payload hash. *)\n val current_witness :\n t -> Sc_rollup_inbox_merkelized_payload_hashes_repr.Hash.t\nend\n\n(** Versioning, see {!Sc_rollup_data_version_sig.S} for more information. *)\ninclude Sc_rollup_data_version_sig.S with type t = V1.t\n\ninclude\n module type of V1\n with type level_proof = V1.level_proof\n and type history_proof = V1.history_proof\n and type t = V1.t\n\ntype serialized_proof\n\nval serialized_proof_encoding : serialized_proof Data_encoding.t\n\n(** [add_all_messages history inbox messages] starts a new inbox level,\n adds all the [messages], then ends the inbox level. It can\n be called even if [payloads] is empty.\n\n Remembers everything needed in a created [payloads_history] and [history].\n It is meant to be used by the rollup-node to reduce the risk of\n de-synchronisation between the protocol and the node.\n\n Adds the messages pushed by the protocol and returns a list of messages\n including them. The caller will need to execute this list of messages,\n otherwise, it might miss some internal inputs.\n *)\nval add_all_messages :\n predecessor_timestamp:Time.t ->\n predecessor:Block_hash.t ->\n History.t ->\n t ->\n Sc_rollup_inbox_message_repr.t list ->\n (Sc_rollup_inbox_merkelized_payload_hashes_repr.History.t\n * History.t\n * t\n * Sc_rollup_inbox_merkelized_payload_hashes_repr.t\n * Sc_rollup_inbox_message_repr.t list)\n tzresult\n\n(** [add_messages_no_history payloads witness] updates the [witness] by\n inserting the [payloads]. *)\nval add_messages_no_history :\n Sc_rollup_inbox_message_repr.serialized list ->\n Sc_rollup_inbox_merkelized_payload_hashes_repr.t ->\n Sc_rollup_inbox_merkelized_payload_hashes_repr.t tzresult\n\n(** Used at the beginning of a refutation game to create the\n snapshot against which proofs in that game must be valid.\n\n One important note:\n It takes the snapshot of the inbox for the current level. The snapshot\n points to the inbox at the *beginning* of the current block level. This\n prevents to create a mid-level snapshot for a refutation game if new\n messages are added before and/or after in the same block. *)\nval take_snapshot : t -> history_proof\n\n(** Given a inbox [A] at some level [L] and another inbox [B] at some level [L'\n >= L], an [inclusion_proof] guarantees that [A] is an older version of [B].\n\n To be more precise, an [inclusion_proof] guarantees that the previous levels\n [level_tree]s of [A] are included in the previous levels [level_tree]s of\n [B]. The current [level_tree] of [A] and [B] are not considered.\n\n The size of this proof is O(log2 (L' - L)). *)\ntype inclusion_proof\n\nval inclusion_proof_encoding : inclusion_proof Data_encoding.t\n\nval pp_inclusion_proof : Format.formatter -> inclusion_proof -> unit\n\n(** [number_of_proof_steps proof] returns the length of [proof]. *)\nval number_of_proof_steps : inclusion_proof -> int\n\n(** [verify_inclusion_proof proof snapshot] returns [A] iff [proof] is a minimal\n and valid proof that [A] is included in [snapshot], fails otherwise. [A] is\n part of the proof. *)\nval verify_inclusion_proof :\n inclusion_proof -> history_proof -> history_proof tzresult\n\n(** An inbox proof has three parameters:\n\n - the [starting_point], of type [Raw_level_repr.t * Z.t], specifying\n a location in the inbox ;\n\n - the [message], of type [Sc_rollup_PVM_sig.input option] ;\n\n - and a reference [snapshot] inbox.\n\n A valid inbox proof implies the following semantics: beginning at\n [starting_point] and reading forward through [snapshot], the first\n message you reach will be [message].\n\n Usually this is fairly simple because there will actually be a\n message at the location specified by [starting_point]. But in some\n cases [starting_point] is past the last message within a level,\n and then the inbox proof's verification assumes that the next input\n is the SOL of the next level, if not beyond the snapshot.\n*)\ntype proof\n\nval pp_proof : Format.formatter -> proof -> unit\n\nval to_serialized_proof : proof -> serialized_proof\n\nval of_serialized_proof : serialized_proof -> proof option\n\n(** See the docstring for the [proof] type for details of proof semantics.\n\n [verify_proof starting_point inbox_snapshot proof] will return the third\n parameter of the proof, [message], iff the proof is valid. *)\nval verify_proof :\n Raw_level_repr.t * Z.t ->\n history_proof ->\n proof ->\n Sc_rollup_PVM_sig.inbox_message option tzresult\n\n(** [produce_proof ~get_payloads_history ~get_history inbox (level, counter)]\n creates an inbox proof proving the first message after the index [counter]\n at location [level]. This will fail if the [get_payloads_history] given\n doesn't have sufficient data (it needs to be run on an with a full\n history). *)\nval produce_proof :\n get_payloads_history:\n (Sc_rollup_inbox_merkelized_payload_hashes_repr.Hash.t ->\n Sc_rollup_inbox_merkelized_payload_hashes_repr.History.t Lwt.t) ->\n get_history:(Hash.t -> history_proof option Lwt.t) ->\n history_proof ->\n Raw_level_repr.t * Z.t ->\n (proof * Sc_rollup_PVM_sig.inbox_message option) tzresult Lwt.t\n\n(** [init_witness_no_history] initializes the witness for a new inbox level\n by adding the first input, i.e. [Start_of_level]. *)\nval init_witness_no_history : Sc_rollup_inbox_merkelized_payload_hashes_repr.t\n\n(** [add_info_per_level_no_history] adds the input [Info_per_level]. *)\nval add_info_per_level_no_history :\n predecessor_timestamp:Time.t ->\n predecessor:Block_hash.t ->\n Sc_rollup_inbox_merkelized_payload_hashes_repr.t ->\n Sc_rollup_inbox_merkelized_payload_hashes_repr.t tzresult\n\n(** [finalize_inbox_level payloads_history history inbox level_witness] updates\n the current inbox's level witness by adding [EOL], and archives the current\n level. *)\nval finalize_inbox_level_no_history :\n t -> Sc_rollup_inbox_merkelized_payload_hashes_repr.t -> t tzresult\n\n(** [genesis ~timestamp ~predecessor level] initializes the inbox at some\n given [level] with: SOL, Info_per_level {timestamp; predecessor} and EOL\n inside. *)\nval genesis :\n predecessor_timestamp:Time.t ->\n predecessor:Block_hash.t ->\n Raw_level_repr.t ->\n t tzresult\n\nmodule Internal_for_tests : sig\n (** [produce_inclusion_proof get_history a b] exploits [get_history]\n to produce a self-contained proof that [a] is an older version of [b]. *)\n val produce_inclusion_proof :\n (Hash.t -> history_proof option Lwt.t) ->\n history_proof ->\n Raw_level_repr.t ->\n (inclusion_proof * history_proof) tzresult Lwt.t\n\n (** Allows to create a dumb {!serialized_proof} from a string, instead of\n serializing a proof with {!to_serialized_proof}. *)\n val serialized_proof_of_string : string -> serialized_proof\n\n val get_level_of_history_proof : history_proof -> Raw_level_repr.t\nend\n\ntype inbox = t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(**\n\n A Merkelized inbox represents a list of messages. This list\n is decomposed into sublists of messages, one for each Tezos level greater\n than the level where SCORU is activated.\n\n This module is designed to:\n\n 1. provide a space-efficient representation for proofs of inbox\n inclusions (only for inboxes obtained at the end of block\n validation) ;\n\n 2. offer an efficient function to add a new batch of messages in the\n inbox at the current level.\n\n To solve (1), we use a proof tree H which is implemented by a merkelized skip\n list allowing for compact inclusion proofs (See {!skip_list_repr.ml}).\n\n To solve (2), we maintain a separate proof tree C witnessing the contents of\n messages of the current level also implemented by a merkelized skip list for\n the same reason.\n\n The protocol maintains the hashes of the head of H and C.\n\n The rollup node needs to maintain a full representation for C and a\n partial representation for H back to the level of the LCC.\n\n*)\ntype error += Inbox_proof_error of string\n\ntype error += Tried_to_add_zero_messages\n\ntype error += Inbox_level_reached_messages_limit\n\nlet () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"internal.smart_rollup_inbox_proof_error\"\n ~title:\n \"Internal error: error occurred during proof production or validation\"\n ~description:\"An inbox proof error.\"\n ~pp:(fun ppf e -> Format.fprintf ppf \"Inbox proof error: %s\" e)\n (obj1 (req \"error\" (string Plain)))\n (function Inbox_proof_error e -> Some e | _ -> None)\n (fun e -> Inbox_proof_error e) ;\n\n register_error_kind\n `Permanent\n ~id:\"internal.smart_rollup_add_zero_messages\"\n ~title:\"Internal error: trying to add zero messages\"\n ~description:\n \"Message adding functions must be called with a positive number of \\\n messages\"\n ~pp:(fun ppf _ -> Format.fprintf ppf \"Tried to add zero messages\")\n empty\n (function Tried_to_add_zero_messages -> Some () | _ -> None)\n (fun () -> Tried_to_add_zero_messages) ;\n\n let description =\n Format.sprintf\n \"There can be only %s messages in an inbox level, the limit has been \\\n reached.\"\n (Z.to_string Constants_repr.sc_rollup_max_number_of_messages_per_level)\n in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_inbox_level_reached_message_limit\"\n ~title:\"Inbox level reached messages limit\"\n ~description\n ~pp:(fun ppf _ -> Format.pp_print_string ppf description)\n empty\n (function Inbox_level_reached_messages_limit -> Some () | _ -> None)\n (fun () -> Inbox_level_reached_messages_limit)\n\nmodule Int64_map = Map.Make (Int64)\n\n(* 32 *)\nlet hash_prefix = \"\\003\\255\\138\\145\\110\" (* srib1(55) *)\n\nmodule Hash = struct\n let prefix = \"srib1\"\n\n let encoded_size = 55\n\n module H =\n Blake2B.Make\n (Base58)\n (struct\n let name = \"Smart_rollup_inbox_hash\"\n\n let title = \"The hash of an inbox of a smart rollup\"\n\n let b58check_prefix = hash_prefix\n\n (* defaults to 32 *)\n let size = None\n end)\n\n include H\n\n let () = Base58.check_encoded_prefix b58check_encoding prefix encoded_size\n\n include Path_encoding.Make_hex (H)\nend\n\nmodule Skip_list_parameters = struct\n let basis = 4\nend\n\nmodule Skip_list = Skip_list_repr.Make (Skip_list_parameters)\n\nmodule V1 = struct\n type level_proof = {\n hash : Sc_rollup_inbox_merkelized_payload_hashes_repr.Hash.t;\n level : Raw_level_repr.t;\n }\n\n let level_proof_encoding =\n let open Data_encoding in\n conv\n (fun {hash; level} -> (hash, level))\n (fun (hash, level) -> {hash; level})\n (obj2\n (req\n \"hash\"\n Sc_rollup_inbox_merkelized_payload_hashes_repr.Hash.encoding)\n (req \"level\" Raw_level_repr.encoding))\n\n let equal_level_proof {hash; level} level_proof_2 =\n Sc_rollup_inbox_merkelized_payload_hashes_repr.Hash.equal\n hash\n level_proof_2.hash\n && Raw_level_repr.equal level level_proof_2.level\n\n type history_proof = (level_proof, Hash.t) Skip_list.cell\n\n let hash_history_proof cell =\n let {hash; level} = Skip_list.content cell in\n let back_pointers_hashes = Skip_list.back_pointers cell in\n Sc_rollup_inbox_merkelized_payload_hashes_repr.Hash.to_bytes hash\n :: (Raw_level_repr.to_int32 level |> Int32.to_string |> Bytes.of_string)\n :: List.map Hash.to_bytes back_pointers_hashes\n |> Hash.hash_bytes\n\n let equal_history_proof = Skip_list.equal Hash.equal equal_level_proof\n\n let history_proof_encoding : history_proof Data_encoding.t =\n Skip_list.encoding Hash.encoding level_proof_encoding\n\n let pp_level_proof fmt {hash; level} =\n Format.fprintf\n fmt\n \"hash: %a@,level: %a\"\n Sc_rollup_inbox_merkelized_payload_hashes_repr.Hash.pp\n hash\n Raw_level_repr.pp\n level\n\n let pp_history_proof fmt history_proof =\n (Skip_list.pp ~pp_content:pp_level_proof ~pp_ptr:Hash.pp) fmt history_proof\n\n (** Construct an inbox [history] with a given [capacity]. If you\n are running a rollup node, [capacity] needs to be large enough to\n remember any levels for which you may need to produce proofs. *)\n module History =\n Bounded_history_repr.Make\n (struct\n let name = \"Smart_rollup_inbox_history\"\n end)\n (Hash)\n (struct\n type t = history_proof\n\n let pp = pp_history_proof\n\n let equal = equal_history_proof\n\n let encoding = history_proof_encoding\n end)\n\n (* An inbox is composed of a metadata of type {!t}, and a [level witness]\n representing the messages of the current level (held by the\n [Raw_context.t] in the protocol).\n\n The metadata contains :\n - [level] : the inbox level ;\n - [old_levels_messages] : a witness of the inbox history.\n *)\n type t = {level : Raw_level_repr.t; old_levels_messages : history_proof}\n\n let equal inbox1 inbox2 =\n (* To be robust to addition of fields in [t]. *)\n let {level; old_levels_messages} = inbox1 in\n Raw_level_repr.equal level inbox2.level\n && equal_history_proof old_levels_messages inbox2.old_levels_messages\n\n let pp fmt {level; old_levels_messages} =\n Format.fprintf\n fmt\n \"@[<hov 2>{ level = %a@;old_levels_messages = %a@;}@]\"\n Raw_level_repr.pp\n level\n pp_history_proof\n old_levels_messages\n\n let hash inbox = hash_history_proof inbox.old_levels_messages\n\n let inbox_level inbox = inbox.level\n\n let old_levels_messages inbox = inbox.old_levels_messages\n\n let current_witness inbox =\n let {hash; _} = Skip_list.content inbox.old_levels_messages in\n hash\n\n let encoding =\n Data_encoding.(\n conv\n (fun {level; old_levels_messages} -> (level, old_levels_messages))\n (fun (level, old_levels_messages) -> {level; old_levels_messages})\n (obj2\n (req \"level\" Raw_level_repr.encoding)\n (req \"old_levels_messages\" history_proof_encoding)))\nend\n\ntype versioned = V1 of V1.t\n\nlet versioned_encoding =\n let open Data_encoding in\n union\n [\n case\n ~title:\"V1\"\n (Tag 0)\n V1.encoding\n (function V1 inbox -> Some inbox)\n (fun inbox -> V1 inbox);\n ]\n\ninclude V1\n\nlet of_versioned = function V1 inbox -> inbox [@@inline]\n\nlet to_versioned inbox = V1 inbox [@@inline]\n\ntype serialized_proof = string\n\nlet serialized_proof_encoding = Data_encoding.(string Hex)\n\ntype level_tree_proof = {\n proof : Sc_rollup_inbox_merkelized_payload_hashes_repr.proof;\n payload : Sc_rollup_inbox_message_repr.serialized option;\n}\n\nlet level_tree_proof_encoding =\n let open Data_encoding in\n conv\n (fun {proof; payload} -> (proof, (payload :> string option)))\n (fun (proof, payload) ->\n {\n proof;\n payload =\n Option.map Sc_rollup_inbox_message_repr.unsafe_of_string payload;\n })\n (obj2\n (req\n \"proof\"\n Sc_rollup_inbox_merkelized_payload_hashes_repr.proof_encoding)\n (opt \"payload\" (string Hex)))\n\nlet add_protocol_internal_message payload payloads_history witness =\n Sc_rollup_inbox_merkelized_payload_hashes_repr.add_payload\n payloads_history\n witness\n payload\n\nlet add_message payload payloads_history witness =\n let open Result_syntax in\n let message_counter =\n Sc_rollup_inbox_merkelized_payload_hashes_repr.get_index witness\n in\n let* () =\n let max_number_of_messages_per_level =\n Constants_repr.sc_rollup_max_number_of_messages_per_level\n in\n error_unless\n Compare.Z.(message_counter <= max_number_of_messages_per_level)\n Inbox_level_reached_messages_limit\n in\n Sc_rollup_inbox_merkelized_payload_hashes_repr.add_payload\n payloads_history\n witness\n payload\n\n(** [no_history] creates an empty history with [capacity] set to\n zero---this makes the [remember] function a no-op. We want this\n behaviour in the protocol because we don't want to store\n previous levels of the inbox. *)\nlet no_history = History.empty ~capacity:0L\n\nlet take_snapshot inbox = inbox.old_levels_messages\n\n(** [archive history inbox witness] archives the current inbox level depending\n on the [history] parameter's [capacity]. Updates the\n [inbox.current_level] and [inbox.old_levels_messages]. *)\nlet archive history inbox witness =\n let open Result_syntax in\n (* [form_history_proof history inbox] adds the current inbox level to the\n history and creates new [inbox.old_levels_messages] including\n the current level. *)\n let form_history_proof history inbox =\n let prev_cell = inbox.old_levels_messages in\n let prev_cell_ptr = hash_history_proof prev_cell in\n let* history = History.remember prev_cell_ptr prev_cell history in\n let current_level_proof =\n let hash = Sc_rollup_inbox_merkelized_payload_hashes_repr.hash witness in\n {hash; level = inbox.level}\n in\n let cell = Skip_list.next ~prev_cell ~prev_cell_ptr current_level_proof in\n return (history, cell)\n in\n let* history, old_levels_messages = form_history_proof history inbox in\n let inbox = {inbox with old_levels_messages} in\n return (history, inbox)\n\nlet add_messages payloads_history payloads witness =\n let open Result_syntax in\n let* () =\n error_when\n (match payloads with [] -> true | _ -> false)\n Tried_to_add_zero_messages\n in\n let* payloads_history, witness =\n List.fold_left_e\n (fun (payloads_history, witness) payload ->\n add_message payload payloads_history witness)\n (payloads_history, witness)\n payloads\n in\n return (payloads_history, witness)\n\nlet add_messages_no_history payloads witness =\n let open Result_syntax in\n let+ _, witness =\n add_messages\n Sc_rollup_inbox_merkelized_payload_hashes_repr.History.no_history\n payloads\n witness\n in\n witness\n\n(* An [inclusion_proof] is a path in the Merkelized skip list\n showing that a given inbox history is a prefix of another one.\n This path has a size logarithmic in the difference between the\n levels of the two inboxes. *)\ntype inclusion_proof = history_proof list\n\nlet inclusion_proof_encoding =\n let open Data_encoding in\n list history_proof_encoding\n\nlet pp_inclusion_proof fmt proof =\n Format.pp_print_list pp_history_proof fmt proof\n\nlet number_of_proof_steps proof = List.length proof\n\n(* See the main docstring for this type (in the mli file) for\n definitions of the three proof parameters [starting_point],\n [message] and [snapshot]. In the below we deconstruct\n [starting_point] into [(l, n)] where [l] is a level and [n] is a\n message index.\n\n In a proof, [inclusion_proof] is an inclusion proof of [history_proof] into\n [snapshot] where [history_proof] is the skip list cell for the level [l],\n and [message_proof] is a tree proof showing that\n\n [exists witness .\n (hash_level_tree witness = history_proof.content.hash)\n AND (get_messages_payload n witness = (_, message))]\n\n Note: in the case that [message] is [None] this shows that there's no\n value at the index [n]; in this case we also must check that\n [history_proof] equals [snapshot]. *)\ntype proof = {\n inclusion_proof : inclusion_proof;\n message_proof : level_tree_proof;\n}\n\nlet pp_proof fmt {inclusion_proof; message_proof = _} =\n Format.fprintf\n fmt\n \"inclusion proof: %a@\"\n (Format.pp_print_list pp_history_proof)\n inclusion_proof\n\nlet proof_encoding =\n let open Data_encoding in\n conv\n (fun {inclusion_proof; message_proof} -> (inclusion_proof, message_proof))\n (fun (inclusion_proof, message_proof) -> {inclusion_proof; message_proof})\n (obj2\n (req \"inclusion_proof\" inclusion_proof_encoding)\n (req \"message_proof\" level_tree_proof_encoding))\n\nlet of_serialized_proof = Data_encoding.Binary.of_string_opt proof_encoding\n\nlet to_serialized_proof = Data_encoding.Binary.to_string_exn proof_encoding\n\n(** [verify_payloads_proof {proof; payload} head_cell_hash n label] handles\n all the verification needed for a particular message proof at a particular\n level.\n\n First it checks that [proof] is a valid inclusion of [payload_cell] in\n [head_cell] and that [head_cell] hash is [head_cell_hash].\n\n Then there is two cases,\n\n - either [n] is superior to the index of [head_cell] then the provided\n [payload] must be empty (and [payload_cell = head_cell]);\n\n - or [0 < n < max_index head_cell] then the provided payload must exist and\n the payload hash must equal the content of the [payload_cell].\n*)\nlet verify_payloads_proof {proof; payload} head_cell_hash n =\n let open Result_syntax in\n let* payload_cell, head_cell =\n Sc_rollup_inbox_merkelized_payload_hashes_repr.verify_proof proof\n in\n (* Checks that [proof] is a valid inclusion of [payload_cell] in\n [head_cell] and that [head_cell] hash is [head_cell_hash]. *)\n let* () =\n error_unless\n (Sc_rollup_inbox_merkelized_payload_hashes_repr.Hash.equal\n head_cell_hash\n (Sc_rollup_inbox_merkelized_payload_hashes_repr.hash head_cell))\n (Inbox_proof_error (Format.sprintf \"message_proof does not match history\"))\n in\n let max_index =\n Sc_rollup_inbox_merkelized_payload_hashes_repr.get_index head_cell\n in\n if Compare.Z.(n = Z.succ max_index) then\n (* [n] is equal to the index of [head_cell] then the provided [payload] must\n be init (,and [payload_cell = head_cell]) *)\n let* () =\n error_unless\n (Option.is_none payload)\n (Inbox_proof_error \"Payload provided but none expected\")\n in\n let* () =\n error_unless\n (Sc_rollup_inbox_merkelized_payload_hashes_repr.equal\n payload_cell\n head_cell)\n (Inbox_proof_error \"Provided proof is about a unexpected payload\")\n in\n return_none\n else if Compare.Z.(n <= max_index) then\n (* [0 < n < max_index head_cell] then the provided [payload] must exists and\n [payload_hash] must equal the content of the [payload_cell]. *)\n let* payload =\n match payload with\n | Some payload -> return payload\n | None ->\n tzfail\n (Inbox_proof_error\n \"Expected a payload but none provided in the proof\")\n in\n let payload_hash =\n Sc_rollup_inbox_message_repr.hash_serialized_message payload\n in\n let proven_payload_hash =\n Sc_rollup_inbox_merkelized_payload_hashes_repr.get_payload_hash\n payload_cell\n in\n let* () =\n error_unless\n (Sc_rollup_inbox_message_repr.Hash.equal\n payload_hash\n proven_payload_hash)\n (Inbox_proof_error\n \"the payload provided does not match the payload's hash found in \\\n the message proof\")\n in\n let payload_index =\n Sc_rollup_inbox_merkelized_payload_hashes_repr.get_index payload_cell\n in\n let* () =\n error_unless\n (Compare.Z.equal n payload_index)\n (Inbox_proof_error\n (Format.sprintf \"found index in message_proof is incorrect\"))\n in\n return_some payload\n else\n tzfail\n (Inbox_proof_error\n \"Provided message counter is out of the valid range [0 -- (max_index \\\n + 1)] \")\n\n(** [produce_payloads_proof get_paylooads_history head_cell_hash ~index]\n\n [get_paylooads_history cell_hash] is a function that returns an\n {!Sc_rollup_inbox_merkelized_payload_hashes_repr.History.t}. The returned\n history must contains the cell with hash [cell_hash], all its ancestor cell\n and their associated payload.\n\n [head_cell] the latest cell of the [witness] we want to produce a proof on\n with hash [head_cell_hash].\n\n This function produce either:\n\n - if [index <= head_cell_max_index], a proof that [payload_cell] with\n [index] is an ancestor to [head_cell] where [head_cell] is the cell with\n hash [head_cell_hash]. It returns the proof and the payload associated to\n [payload_cell];\n\n - else a proof that [index] is out of bound for [head_cell]. It returns the\n proof and no payload.\n*)\nlet produce_payloads_proof get_paylooads_history head_cell_hash ~index =\n let open Lwt_result_syntax in\n (* We first retrieve the history of cells for this level. *)\n let*! payloads_history = get_paylooads_history head_cell_hash in\n (* We then fetch the actual head cell in the history. *)\n let*? head_cell =\n match\n Sc_rollup_inbox_merkelized_payload_hashes_repr.History.find\n head_cell_hash\n payloads_history\n with\n | Some {merkelized = head_cell; payload = _} -> ok head_cell\n | None ->\n error\n (Inbox_proof_error \"could not find head_cell in the payloads_history\")\n in\n let head_cell_max_index =\n Sc_rollup_inbox_merkelized_payload_hashes_repr.get_index head_cell\n in\n (* if [index <= level_tree_max_index] then the index belongs to this level, we\n prove its existence. Else the index is out of bounds, we prove its\n non-existence. *)\n let target_index = Compare.Z.(min index head_cell_max_index) in\n (* We look for the cell at `target_index` starting from `head_cell`. If it\n exists, we return the payload held in this cell. Otherwise, we prove that\n [index] does not exist in this level. *)\n let proof =\n Sc_rollup_inbox_merkelized_payload_hashes_repr.produce_proof\n payloads_history\n head_cell\n ~index:target_index\n in\n match proof with\n | Some ({payload; merkelized = _}, proof) ->\n if Compare.Z.(target_index = index) then\n return {proof; payload = Some payload}\n else return {proof; payload = None}\n | None -> tzfail (Inbox_proof_error \"could not produce a valid proof.\")\n\nlet verify_inclusion_proof inclusion_proof snapshot_history_proof =\n let open Result_syntax in\n let rec aux (hash_map, ptr_list) = function\n | [] -> error (Inbox_proof_error \"inclusion proof is empty\")\n | [target] ->\n let target_ptr = hash_history_proof target in\n let hash_map = Hash.Map.add target_ptr target hash_map in\n let ptr_list = target_ptr :: ptr_list in\n ok (hash_map, List.rev ptr_list, target, target_ptr)\n | history_proof :: tail ->\n let ptr = hash_history_proof history_proof in\n aux (Hash.Map.add ptr history_proof hash_map, ptr :: ptr_list) tail\n in\n let* hash_map, ptr_list, target, target_ptr =\n aux (Hash.Map.empty, []) inclusion_proof\n in\n let deref ptr = Hash.Map.find ptr hash_map in\n let cell_ptr = hash_history_proof snapshot_history_proof in\n let* () =\n error_unless\n (Skip_list.valid_back_path\n ~equal_ptr:Hash.equal\n ~deref\n ~cell_ptr\n ~target_ptr\n ptr_list)\n (Inbox_proof_error \"invalid inclusion proof\")\n in\n return target\n\nlet produce_inclusion_proof deref inbox_snapshot l =\n let open Lwt_result_syntax in\n let compare {hash = _; level} = Raw_level_repr.compare level l in\n let*! result = Skip_list.Lwt.search ~deref ~compare ~cell:inbox_snapshot in\n match result with\n | Skip_list.{rev_path; last_cell = Found history_proof} ->\n return (List.rev rev_path, history_proof)\n | {last_cell = Nearest _; _}\n | {last_cell = No_exact_or_lower_ptr; _}\n | {last_cell = Deref_returned_none; _} ->\n (* We are only interested in the result where [search] returns a path to\n the cell we were looking for. All the other cases should be\n considered as an error. *)\n tzfail\n @@ Inbox_proof_error\n (Format.asprintf\n \"Skip_list.search failed to find a valid path: %a\"\n (Skip_list.pp_search_result ~pp_cell:pp_history_proof)\n result)\n\nlet verify_proof (l, n) inbox_snapshot {inclusion_proof; message_proof} =\n assert (Z.(geq n zero)) ;\n let open Result_syntax in\n let* history_proof = verify_inclusion_proof inclusion_proof inbox_snapshot in\n let level_proof = Skip_list.content history_proof in\n let* payload_opt = verify_payloads_proof message_proof level_proof.hash n in\n match payload_opt with\n | Some payload ->\n return_some\n Sc_rollup_PVM_sig.{inbox_level = l; message_counter = n; payload}\n | None ->\n if equal_history_proof inbox_snapshot history_proof then return_none\n else\n let* payload =\n Sc_rollup_inbox_message_repr.(serialize (Internal Start_of_level))\n in\n let inbox_level = Raw_level_repr.succ l in\n let message_counter = Z.zero in\n return_some Sc_rollup_PVM_sig.{inbox_level; message_counter; payload}\n\nlet produce_proof ~get_payloads_history ~get_history inbox_snapshot (l, n) =\n let open Lwt_result_syntax in\n let* inclusion_proof, history_proof =\n produce_inclusion_proof get_history inbox_snapshot l\n in\n let level_proof = Skip_list.content history_proof in\n let* ({payload; proof = _} as message_proof) =\n produce_payloads_proof get_payloads_history level_proof.hash ~index:n\n in\n let proof = {inclusion_proof; message_proof} in\n let*? input =\n let open Result_syntax in\n match payload with\n | Some payload ->\n return_some\n Sc_rollup_PVM_sig.{inbox_level = l; message_counter = n; payload}\n | None ->\n (* No payload means that there is no more message to read at the level of\n [history_proof]. *)\n if equal_history_proof inbox_snapshot history_proof then\n (* if [history_proof] is equal to the snapshot then it means that there\n is no more message to read. *)\n return_none\n else\n (* Else we must read the [sol] of the next level. *)\n let inbox_level = Raw_level_repr.succ l in\n let message_counter = Z.zero in\n let* payload =\n Sc_rollup_inbox_message_repr.(serialize (Internal Start_of_level))\n in\n return_some Sc_rollup_PVM_sig.{inbox_level; message_counter; payload}\n in\n return (proof, input)\n\nlet init_witness payloads_history =\n let open Result_syntax in\n let sol = Sc_rollup_inbox_message_repr.start_of_level_serialized in\n let* payloads_history, witness =\n Sc_rollup_inbox_merkelized_payload_hashes_repr.genesis payloads_history sol\n in\n return (payloads_history, witness)\n\nlet init_witness_no_history =\n let no_payloads_history =\n Sc_rollup_inbox_merkelized_payload_hashes_repr.History.no_history\n in\n let res = init_witness no_payloads_history in\n match res with\n | Ok (_payloads_history, witness) -> witness\n | Error _ ->\n (* We extract the [witness] from the result monad so the caller does\n not have to deal with the error case. This is a top-level declaration,\n this will fail at compile-time. *)\n (* TODO: https://gitlab.com/tezos/tezos/-/issues/4359\n\n Adding [SOL] without the history could remove the result monad here. *)\n assert false\n\nlet add_info_per_level ~predecessor_timestamp ~predecessor payloads_history\n witness =\n let open Result_syntax in\n let* info_per_level =\n Sc_rollup_inbox_message_repr.(\n serialize (Internal (Info_per_level {predecessor_timestamp; predecessor})))\n in\n add_protocol_internal_message info_per_level payloads_history witness\n\nlet add_info_per_level_no_history ~predecessor_timestamp ~predecessor witness =\n let open Result_syntax in\n let no_payloads_history =\n Sc_rollup_inbox_merkelized_payload_hashes_repr.History.no_history\n in\n let* _payloads_history, witness =\n add_info_per_level\n ~predecessor_timestamp\n ~predecessor\n no_payloads_history\n witness\n in\n return witness\n\nlet finalize_inbox_level payloads_history history inbox witness =\n let open Result_syntax in\n let inbox = {inbox with level = Raw_level_repr.succ inbox.level} in\n let eol = Sc_rollup_inbox_message_repr.end_of_level_serialized in\n let* payloads_history, witness =\n add_protocol_internal_message eol payloads_history witness\n in\n let* history, inbox = archive history inbox witness in\n return (payloads_history, history, witness, inbox)\n\nlet finalize_inbox_level_no_history inbox witness =\n let open Result_syntax in\n let* _payloads_history, _history, _witness, inbox =\n finalize_inbox_level\n Sc_rollup_inbox_merkelized_payload_hashes_repr.History.no_history\n no_history\n inbox\n witness\n in\n return inbox\n\nlet add_all_messages ~predecessor_timestamp ~predecessor history inbox messages\n =\n let open Result_syntax in\n let* payloads = List.map_e Sc_rollup_inbox_message_repr.serialize messages in\n let payloads_history =\n (* Must remember every [payloads] and internal messages pushed by the\n protocol: SOL/Info_per_level/EOL. *)\n let capacity = List.length payloads + 3 |> Int64.of_int in\n Sc_rollup_inbox_merkelized_payload_hashes_repr.History.empty ~capacity\n in\n (* Add [SOL] and [Info_per_level]. *)\n let* payloads_history, witness = init_witness payloads_history in\n let* payloads_history, witness =\n add_info_per_level\n ~predecessor_timestamp\n ~predecessor\n payloads_history\n witness\n in\n\n let* payloads_history, witness =\n match payloads with\n | [] -> return (payloads_history, witness)\n | payloads -> add_messages payloads_history payloads witness\n in\n let* payloads_history, history, witness, inbox =\n finalize_inbox_level payloads_history history inbox witness\n in\n\n (* Wrap the messages so the caller can execute every actual messages\n for this inbox. *)\n let messages =\n let open Sc_rollup_inbox_message_repr in\n let sol = Internal Start_of_level in\n let info_per_level =\n Internal (Info_per_level {predecessor_timestamp; predecessor})\n in\n let eol = Internal End_of_level in\n [sol; info_per_level] @ messages @ [eol]\n in\n\n return (payloads_history, history, inbox, witness, messages)\n\nlet genesis ~predecessor_timestamp ~predecessor level =\n let open Result_syntax in\n let no_payloads_history =\n Sc_rollup_inbox_merkelized_payload_hashes_repr.History.no_history\n in\n (* 1. Add [SOL] and [Info_per_level]. *)\n let witness = init_witness_no_history in\n let* witness =\n add_info_per_level_no_history ~predecessor_timestamp ~predecessor witness\n in\n\n (* 2. Add [EOL]. *)\n let eol = Sc_rollup_inbox_message_repr.end_of_level_serialized in\n let* _payloads_history, witness =\n add_protocol_internal_message eol no_payloads_history witness\n in\n\n let level_proof =\n let hash = Sc_rollup_inbox_merkelized_payload_hashes_repr.hash witness in\n {hash; level}\n in\n\n return {level; old_levels_messages = Skip_list.genesis level_proof}\n\nmodule Internal_for_tests = struct\n let produce_inclusion_proof = produce_inclusion_proof\n\n let serialized_proof_of_string x = x\n\n let get_level_of_history_proof (history_proof : history_proof) =\n let ({level; _} : level_proof) = Skip_list.content history_proof in\n level\nend\n\ntype inbox = t\n" ;
} ;
{ name = "Sc_rollup_staker_index_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t = private Z.t\n\nval zero : t\n\nval succ : t -> t\n\nval encoding : t Data_encoding.t\n\nval equal : t -> t -> bool\n\nmodule Index : Storage_description.INDEX with type t = t\n\nmodule Internal_for_tests : sig\n val of_z : Z.t -> t\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ninclude Z\n\nlet encoding = Data_encoding.n\n\nmodule Index : Storage_description.INDEX with type t = t = struct\n type nonrec t = t\n\n let encoding = encoding\n\n let compare = compare\n\n let path_length = 1\n\n let to_path c l = Z.to_string c :: l\n\n let of_path = function\n | [] | _ :: _ :: _ -> None\n | [c] -> Some (Z.of_string c)\n\n let rpc_arg =\n let z_of_string s =\n try Ok (Z.of_string s) with Failure _ -> Error \"Cannot parse z value\"\n in\n RPC_arg.make ~name:\"z\" ~destruct:z_of_string ~construct:Z.to_string ()\nend\n\nmodule Internal_for_tests = struct\n let of_z z = z\nend\n" ;
} ;
{ name = "Sc_rollup_commitment_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Sc_rollup_repr\n\nmodule Hash : sig\n include S.HASH\n\n include Storage_description.INDEX with type t := t\nend\n\n(** A commitment represents a claim about the state of the Inbox and PVM at\n some Inbox level.\n\n More formally, a commitment is a claim that:\n\n {ul\n {li assuming the PVM and Inbox are in a state implied by [predecessor]}\n {li the PVM consumes all the messages until [inbox_level] (not included)\n from the inbox ; }\n {li the PVM advances to the state [compressed_state] over\n [number_of_ticks] ticks. }\n }\n\n Commitments are disjoint. The next correct commitment is a function of the\n previous machine state and Inbox.\n\n [compressed_state] and [number_of_ticks] can be proven/disproven by PVM\n execution, or equivalently, by an interactive proof game between\n conflicting parties, such that a correct executor always wins the game.\n*)\nmodule V1 : sig\n type t = {\n compressed_state : State_hash.t;\n inbox_level : Raw_level_repr.t;\n predecessor : Hash.t;\n number_of_ticks : Number_of_ticks.t;\n }\n\n val pp : Format.formatter -> t -> unit\n\n val encoding : t Data_encoding.t\n\n val hash_uncarbonated : t -> Hash.t\n\n (** [genesis_commitment ~origination_level ~genesis_state_hash] is the\n commitment that the protocol \"publish\" and \"cement\" when originating a new\n rollup. Each rollup have a different [genesis_commitment] because the\n [compressed_state] is computed after the boot sector is set. It has the\n following values:\n\n {ul {li [compressed_state] = [genesis_state_hash]}\n {li [inbox_level] = [origination_level]}\n {li [predecessor] = {!Hash.zero}}\n {li [number_of_messages] = {!Sc_rollup_repr.Number_of_messages.min_value}}\n {li [number_of_ticks] = {!Sc_rollup_repr.Number_of_ticks.min_value}}}\n\n where {!Sc_rollup_repr.Number_of_messages.min_value} and\n {!Sc_rollup_repr.Number_of_ticks.min_value} are equal to [zero].\n\n See {!Sc_rollup_storage.originate} for the usage. *)\n val genesis_commitment :\n origination_level:Raw_level_repr.t ->\n genesis_state_hash:Sc_rollup_repr.State_hash.t ->\n t\n\n (** The genesis of a rollup is characterized by the Tezos level of\n the rollup origination, and the hash of the commitment computed\n by the protocol to specialize the PVM initial state with the\n provided boot sector. *)\n type genesis_info = {level : Raw_level_repr.t; commitment_hash : Hash.t}\n\n val genesis_info_encoding : genesis_info Data_encoding.t\nend\n\n(** Versioning, see {!Sc_rollup_data_version_sig.S} for more information. *)\ninclude Sc_rollup_data_version_sig.S with type t = V1.t\n\ninclude module type of V1 with type t = V1.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Sc_rollup_repr\n\n(* 32 *)\nlet hash_prefix = \"\\017\\165\\134\\138\" (* src1(54) *)\n\nmodule Hash = struct\n let prefix = \"src1\"\n\n let encoded_size = 54\n\n module H =\n Blake2B.Make\n (Base58)\n (struct\n let name = \"Smart_rollup_commitment_hash\"\n\n let title = \"The hash of a commitment of a smart rollup\"\n\n let b58check_prefix = hash_prefix\n\n (* defaults to 32 *)\n let size = None\n end)\n\n include H\n\n let () = Base58.check_encoded_prefix b58check_encoding prefix encoded_size\n\n include Path_encoding.Make_hex (H)\nend\n\nmodule V1 = struct\n type t = {\n compressed_state : State_hash.t;\n inbox_level : Raw_level_repr.t;\n predecessor : Hash.t;\n number_of_ticks : Number_of_ticks.t;\n }\n\n let pp fmt {compressed_state; inbox_level; predecessor; number_of_ticks} =\n Format.fprintf\n fmt\n \"compressed_state: %a@,\\\n inbox_level: %a@,\\\n predecessor: %a@,\\\n number_of_ticks: %Ld\"\n State_hash.pp\n compressed_state\n Raw_level_repr.pp\n inbox_level\n Hash.pp\n predecessor\n (Number_of_ticks.to_value number_of_ticks)\n\n let encoding =\n let open Data_encoding in\n conv\n (fun {compressed_state; inbox_level; predecessor; number_of_ticks} ->\n (compressed_state, inbox_level, predecessor, number_of_ticks))\n (fun (compressed_state, inbox_level, predecessor, number_of_ticks) ->\n {compressed_state; inbox_level; predecessor; number_of_ticks})\n (obj4\n (req \"compressed_state\" State_hash.encoding)\n (req \"inbox_level\" Raw_level_repr.encoding)\n (req \"predecessor\" Hash.encoding)\n (req \"number_of_ticks\" Number_of_ticks.encoding))\n\n let hash_uncarbonated commitment =\n let commitment_bytes =\n Data_encoding.Binary.to_bytes_exn encoding commitment\n in\n Hash.hash_bytes [commitment_bytes]\n\n (* For [number_of_messages] and [number_of_ticks] min_value is equal to zero. *)\n let genesis_commitment ~origination_level ~genesis_state_hash =\n let open Sc_rollup_repr in\n let number_of_ticks = Number_of_ticks.zero in\n {\n compressed_state = genesis_state_hash;\n inbox_level = origination_level;\n predecessor = Hash.zero;\n number_of_ticks;\n }\n\n type genesis_info = {level : Raw_level_repr.t; commitment_hash : Hash.t}\n\n let genesis_info_encoding =\n let open Data_encoding in\n conv\n (fun {level; commitment_hash} -> (level, commitment_hash))\n (fun (level, commitment_hash) -> {level; commitment_hash})\n (obj2\n (req \"level\" Raw_level_repr.encoding)\n (req \"commitment_hash\" Hash.encoding))\nend\n\ntype versioned = V1 of V1.t\n\nlet versioned_encoding =\n let open Data_encoding in\n union\n [\n case\n ~title:\"V1\"\n (Tag 0)\n V1.encoding\n (function V1 commitment -> Some commitment)\n (fun commitment -> V1 commitment);\n ]\n\ninclude V1\n\nlet of_versioned = function V1 commitment -> commitment [@@inline]\n\nlet to_versioned commitment = V1 commitment [@@inline]\n" ;
} ;
{ name = "Sc_rollup_proof_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** A refutation game proof is required as part of the final move in a\n game.\n\n This proof is basically a combination of a PVM proof (provided by\n each implementation of the PVM signature) and an input proof. To\n check the proof we must check each part separately and then also\n check that they match on the two points where they touch:\n\n - the [input_requested] of the PVM proof should match the starting\n point of the input proof ;\n\n - the [input_given] of the PVM proof should match the output\n message of the input proof.\n\n It is also often the case that the PVM proof has [No_input_required]\n for its [input_requested] and [None] for its [input_given]. If this\n is the case, we don't need the input proof at all and the [input_proof]\n parameter in our proof should be [None]. *)\n\n(** The proof that a reveal is valid. *)\ntype reveal_proof =\n | Raw_data_proof of string\n (** The existence of reveal for a given hash when the\n [input_requested] is the [Needs_reveal Reveal_raw_data]. *)\n | Metadata_proof\n | Dal_page_proof of {\n page_id : Dal_slot_repr.Page.t;\n proof : Dal_slot_repr.History.proof;\n }\n (** The existence or not of a confirmed slot for a given page ID when the\n [input_requested] is the [Needs_reveal Request_dal_page]. *)\n\n(** A PVM proof [pvm_step] is combined with an [input_proof] to provide\n the proof necessary to validate a single step in the refutation\n game.\n\n If the step doesn't involve any input, [proof_input_requested\n pvm_step] and [proof_input_given pvm_step] will be\n [No_input_required] and [None] respectively, and in this case\n [inbox] should also be [None].\n\n In the case that input is involved, [input_proof] is either:\n\n - a proof of the next inbox message available from the inbox\n after a given location; this must match up with [pvm_step]\n to give a valid refutation proof ; or\n\n - a proof of a reveal satisfiability.\n\n - a claim that the input involved is the first input of the inbox, which\n does not need to be proved as we know by construction what is\n the input (i.e. the [Start_of_level] of the level after the rollup's\n origination level).\n*)\n\ntype input_proof =\n | Inbox_proof of {\n level : Raw_level_repr.t;\n message_counter : Z.t;\n proof : Sc_rollup_inbox_repr.serialized_proof;\n }\n | Reveal_proof of reveal_proof\n | First_inbox_message\n\ntype 'proof t = {pvm_step : 'proof; input_proof : input_proof option}\n\ntype serialized = private string\n\n(** [serialize_pvm_step ~pvm proof] turns a structured representation\n of a step proof of [pvm] into its serialized representation. *)\nval serialize_pvm_step :\n pvm:('state, 'proof, 'output) Sc_rollups.PVM.implementation ->\n 'proof ->\n serialized tzresult\n\n(** [unserialize_pvm_step ~pvm proof] turns a serialized\n representation of a step proof of [pvm] into its structured\n representation. *)\nval unserialize_pvm_step :\n pvm:('state, 'proof, 'output) Sc_rollups.PVM.implementation ->\n serialized ->\n 'proof tzresult\n\ntype error += Sc_rollup_proof_check of string\n\ntype error += Sc_rollup_invalid_serialized_inbox_proof\n\nval serialized_encoding : serialized Data_encoding.t\n\nval encoding : serialized t Data_encoding.t\n\nval pp : Format.formatter -> 'a t -> unit\n\n(** The state hash of the machine before the step. This must be checked\n against the value in the refutation game as well as checking the\n proof is valid. *)\nval start_of_pvm_step :\n pvm:('state, 'proof, 'output) Sc_rollups.PVM.implementation ->\n 'proof ->\n Sc_rollup_repr.State_hash.t\n\n(** The state hash of the machine after the step. This must be checked\n against the value in the refutation game as well as checking the\n proof is valid. *)\nval stop_of_pvm_step :\n pvm:('state, 'proof, 'output) Sc_rollups.PVM.implementation ->\n 'proof ->\n Sc_rollup_repr.State_hash.t\n\n(** Check the validity of a proof.\n\n This function requires a few bits of data (available from the\n refutation game record in the storage):\n\n - a snapshot of the inbox, that may be used by the [input] proof in case\n it's an inbox message ;\n\n - a snapshot of the DAL confirmed slots structure, that may be used by\n the [input] proof in case the input is a DAL page ;\n\n - the inbox level of the commitment, used to determine if an\n output from the [input] proof is too recent to be allowed into\n the PVM proof ;\n\n - DAL parameters and [dal_attestation_lag], to be able to check the page\n content membership to a slot if needed ;\n\n - the [pvm_name], used to check that the proof given has the right\n PVM kind.\n\n It also returns the optional input executed during the proof and the\n input_request for the state at the beginning of the proof.\n*)\nval valid :\n pvm:('state, 'proof, 'output) Sc_rollups.PVM.implementation ->\n metadata:Sc_rollup_metadata_repr.t ->\n Sc_rollup_inbox_repr.history_proof ->\n Raw_level_repr.t ->\n Dal_slot_repr.History.t ->\n Dal_slot_repr.parameters ->\n dal_attestation_lag:int ->\n 'proof t ->\n (Sc_rollup_PVM_sig.input option * Sc_rollup_PVM_sig.input_request) tzresult\n Lwt.t\n\nmodule type PVM_with_context_and_state = sig\n include Sc_rollups.PVM.S\n\n val context : context\n\n val state : state\n\n val proof_encoding : proof Data_encoding.t\n\n val reveal : Sc_rollup_reveal_hash.t -> string option Lwt.t\n\n module Inbox_with_history : sig\n val inbox : Sc_rollup_inbox_repr.history_proof\n\n val get_history :\n Sc_rollup_inbox_repr.Hash.t ->\n Sc_rollup_inbox_repr.history_proof option Lwt.t\n\n val get_payloads_history :\n Sc_rollup_inbox_merkelized_payload_hashes_repr.Hash.t ->\n Sc_rollup_inbox_merkelized_payload_hashes_repr.History.t Lwt.t\n end\n\n (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/3997\n This interface might not be resilient to dal parameters changes\n (cryptobox parameters or dal_attestation_lag for instance). *)\n module Dal_with_history : sig\n (** The reference/snapshot cell of the DAL skip list that stores\n confirmed slots. *)\n val confirmed_slots_history : Dal_slot_repr.History.t\n\n (** A function to retrieve a history from an underlying cache. *)\n val get_history :\n Dal_slot_repr.History.hash -> Dal_slot_repr.History.t option Lwt.t\n\n (** In case we expect to generate an input proof that is a DAL page\n confirmation, we should provide via [page_info] the information of the\n page. That is: its content and the proof that the page is part of a\n confirmed slot whose ID is part of the page's ID.\n\n In case we expect to generate an input proof to justify that a DAL page\n is not confirmed, the value of [page_info] should be [None].\n\n In case the proof doesn't involve DAL inputs, the value of [page_info]\n is [None]. *)\n val page_info :\n (Dal_slot_repr.Page.content * Dal_slot_repr.Page.proof) option\n\n (** Some parameters of the DAL. Needed when checking a page's proof against\n a slot's {!val: Dal_slot_repr.commitment}. *)\n val dal_parameters : Dal_slot_repr.parameters\n\n (** The lag between the time an endorsement is published on L1\n (its published_level) and the level it should be confirmed. *)\n val dal_attestation_lag : int\n end\nend\n\n(** [produce ~metadata pvm_and_state inbox_context inbox_history\n commit_inbox_level] will construct a full refutation game proof out of\n the [state] given in [pvm_and_state]. It uses the [inbox] if necessary to\n provide input in the proof. If the input is above or at [commit_level] it\n will block it, and produce a proof that the PVM is blocked. If\n the input requested is a reveal the proof production will also\n fail.\n\n This will fail if any of the [context], [inbox_context], [inbox_history] or\n [dal_slots_history_cache] given doesn't have enough data to make the proof.\n For example, the 'protocol implementation' version of each PVM won't be\n able to run this function. Similarly, the version of the inbox\n stored in the L1 won't be enough because it forgets old levels.\n\n This uses the [name] in the [pvm_and_state] module to produce an\n encodable [wrapped_proof] if possible. See the [wrap_proof] function\n in [Sc_rollups].\n\n It also need the [metadata] if it produces a proof for the [Needs_metadata]\n state.\n*)\nval produce :\n metadata:Sc_rollup_metadata_repr.t ->\n (module PVM_with_context_and_state) ->\n Raw_level_repr.t ->\n serialized t tzresult Lwt.t\n\n(**/**)\n\nmodule Internal_for_tests : sig\n (** Export internal [cut_at_level] function. See the docstring in the\n implementation file for more information. *)\n val cut_at_level :\n origination_level:Raw_level_repr.t ->\n commit_inbox_level:Raw_level_repr.t ->\n Sc_rollup_PVM_sig.input ->\n Sc_rollup_PVM_sig.input option\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error += Sc_rollup_proof_check of string\n\ntype error += Sc_rollup_invalid_serialized_inbox_proof\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_proof_check\"\n ~title:\"Invalid proof\"\n ~description:\"An invalid proof has been submitted\"\n ~pp:(fun fmt msg -> Format.fprintf fmt \"Invalid proof: %s\" msg)\n Data_encoding.(obj1 @@ req \"reason\" (string Plain))\n (function Sc_rollup_proof_check msg -> Some msg | _ -> None)\n (fun msg -> Sc_rollup_proof_check msg) ;\n\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_invalid_serialized_inbox_proof\"\n ~title:\"Invalid serialized inbox proof\"\n ~description:\"The serialized inbox proof can not be de-serialized\"\n ~pp:(fun fmt () -> Format.fprintf fmt \"Invalid serialized inbox proof\")\n Data_encoding.unit\n (function Sc_rollup_invalid_serialized_inbox_proof -> Some () | _ -> None)\n (fun () -> Sc_rollup_invalid_serialized_inbox_proof)\n\ntype reveal_proof =\n | Raw_data_proof of string\n | Metadata_proof\n | Dal_page_proof of {\n page_id : Dal_slot_repr.Page.t;\n proof : Dal_slot_repr.History.proof;\n }\n\nlet reveal_proof_encoding =\n let open Data_encoding in\n let case_raw_data =\n case\n ~title:\"raw data proof\"\n (Tag 0)\n (obj2\n (req \"reveal_proof_kind\" (constant \"raw_data_proof\"))\n (req\n \"raw_data\"\n Bounded.(\n string\n ~length_kind:`Uint16\n Hex\n Constants_repr.sc_rollup_message_size_limit)))\n (function Raw_data_proof s -> Some ((), s) | _ -> None)\n (fun ((), s) -> Raw_data_proof s)\n and case_metadata_proof =\n case\n ~title:\"metadata proof\"\n (Tag 1)\n (obj1 (req \"reveal_proof_kind\" (constant \"metadata_proof\")))\n (function Metadata_proof -> Some () | _ -> None)\n (fun () -> Metadata_proof)\n in\n let case_dal_page =\n case\n ~title:\"dal page proof\"\n (Tag 2)\n (obj3\n (req \"reveal_proof_kind\" (constant \"dal_page_proof\"))\n (req \"dal_page_id\" Dal_slot_repr.Page.encoding)\n (req \"dal_proof\" Dal_slot_repr.History.proof_encoding))\n (function\n | Dal_page_proof {page_id; proof} -> Some ((), page_id, proof)\n | _ -> None)\n (fun ((), page_id, proof) -> Dal_page_proof {page_id; proof})\n in\n union [case_raw_data; case_metadata_proof; case_dal_page]\n\ntype input_proof =\n | Inbox_proof of {\n level : Raw_level_repr.t;\n message_counter : Z.t;\n proof : Sc_rollup_inbox_repr.serialized_proof;\n }\n | Reveal_proof of reveal_proof\n | First_inbox_message\n\nlet input_proof_encoding =\n let open Data_encoding in\n let proof_kind kind = req \"input_proof_kind\" (constant kind) in\n let case_inbox_proof =\n case\n ~title:\"inbox proof\"\n (Tag 0)\n (obj4\n (proof_kind \"inbox_proof\")\n (req \"level\" Raw_level_repr.encoding)\n (req \"message_counter\" Data_encoding.n)\n (req \"serialized_proof\" Sc_rollup_inbox_repr.serialized_proof_encoding))\n (function\n | Inbox_proof {level; message_counter; proof} ->\n Some ((), level, message_counter, proof)\n | _ -> None)\n (fun ((), level, message_counter, proof) ->\n Inbox_proof {level; message_counter; proof})\n in\n let case_reveal_proof =\n case\n ~title:\"reveal proof\"\n (Tag 1)\n (obj2\n (proof_kind \"reveal_proof\")\n (req \"reveal_proof\" reveal_proof_encoding))\n (function Reveal_proof s -> Some ((), s) | _ -> None)\n (fun ((), s) -> Reveal_proof s)\n in\n let first_input =\n case\n ~title:\"first input\"\n (Tag 2)\n (obj1 (proof_kind \"first_input\"))\n (function First_inbox_message -> Some () | _ -> None)\n (fun () -> First_inbox_message)\n in\n union [case_inbox_proof; case_reveal_proof; first_input]\n\ntype 'proof t = {pvm_step : 'proof; input_proof : input_proof option}\n\ntype serialized = string\n\nlet serialize_pvm_step (type state proof output)\n ~(pvm : (state, proof, output) Sc_rollups.PVM.implementation)\n (proof : proof) : serialized tzresult =\n let open Result_syntax in\n let (module PVM) = pvm in\n match Data_encoding.Binary.to_string_opt PVM.proof_encoding proof with\n | Some p -> return p\n | None -> error (Sc_rollup_proof_check \"Cannot serialize proof\")\n\nlet unserialize_pvm_step (type state proof output)\n ~(pvm : (state, proof, output) Sc_rollups.PVM.implementation)\n (proof : string) : proof tzresult =\n let open Result_syntax in\n let (module PVM) = pvm in\n match Data_encoding.Binary.of_string_opt PVM.proof_encoding proof with\n | Some p -> return p\n | None -> error (Sc_rollup_proof_check \"Cannot unserialize proof\")\n\nlet serialized_encoding = Data_encoding.string Hex\n\nlet encoding =\n let open Data_encoding in\n conv\n (fun {pvm_step; input_proof} -> (pvm_step, input_proof))\n (fun (pvm_step, input_proof) -> {pvm_step; input_proof})\n (obj2\n (req \"pvm_step\" serialized_encoding)\n (opt \"input_proof\" input_proof_encoding))\n\nlet pp ppf _ = Format.fprintf ppf \"Refutation game proof\"\n\nlet start_of_pvm_step (type state proof output)\n ~(pvm : (state, proof, output) Sc_rollups.PVM.implementation)\n (proof : proof) =\n let (module P) = pvm in\n P.proof_start_state proof\n\nlet stop_of_pvm_step (type state proof output)\n ~(pvm : (state, proof, output) Sc_rollups.PVM.implementation)\n (proof : proof) =\n let (module P) = pvm in\n P.proof_stop_state proof\n\n(* This takes an [input] and checks if it is above the given level,\n and if it is at or below the origination level for this rollup.\n It returns [None] if this is the case.\n\n We use this to check that the PVM proof is obeying [commit_inbox_level]\n correctly---if the message obtained from the inbox proof is above\n [commit_inbox_level] the [input_given] in the PVM proof should be [None]. *)\nlet cut_at_level ~origination_level ~commit_inbox_level\n (input : Sc_rollup_PVM_sig.input) =\n match input with\n | Inbox_message {inbox_level = input_level; _} ->\n if\n Raw_level_repr.(\n input_level <= origination_level || commit_inbox_level < input_level)\n then None\n else Some input\n | Reveal _data -> Some input\n\nlet proof_error reason =\n let open Lwt_result_syntax in\n tzfail (Sc_rollup_proof_check reason)\n\nlet check p reason =\n let open Lwt_result_syntax in\n if p then return () else proof_error reason\n\nlet check_inbox_proof snapshot serialized_inbox_proof (level, counter) =\n match Sc_rollup_inbox_repr.of_serialized_proof serialized_inbox_proof with\n | None -> error Sc_rollup_invalid_serialized_inbox_proof\n | Some inbox_proof ->\n Sc_rollup_inbox_repr.verify_proof (level, counter) snapshot inbox_proof\n\nmodule Dal_proofs = struct\n (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/3997\n The current DAL refutation integration is not resilient to DAL parameters\n changes when upgrading the protocol. The code needs to be adapted. *)\n (** Given a page, identified by its ID, we accept to produce or verify a\n proof for it if, and only if, the page's level [page_published_level]\n is in the following boundaries:\n - page_published_level > origination_level: this means that the slot\n of the page was published after the rollup origination ;\n - page_published_level + dal_attestation_lag < commit_level: this\n means that the slot of the page has been confirmed before the\n [commit_level]. According to the definition in\n {!Sc_rollup_commitment_repr}, [commit_level] (aka inbox_level\n in that module) is the level (excluded) up to which the PVM consumed\n all messages and DAL/DAC inputs before producing the related commitment.\n *)\n let page_level_is_valid ~dal_attestation_lag ~origination_level ~commit_level\n page_id =\n (* [dal_attestation_lag] is supposed to be positive. *)\n let page_published_level =\n Dal_slot_repr.(page_id.Page.slot_id.Header.published_level)\n in\n let open Raw_level_repr in\n let not_too_old = page_published_level > origination_level in\n let not_too_recent =\n add page_published_level dal_attestation_lag < commit_level\n in\n not_too_old && not_too_recent\n\n let verify ~metadata ~dal_attestation_lag ~commit_level dal_parameters page_id\n dal_snapshot proof =\n let open Result_syntax in\n if\n page_level_is_valid\n ~origination_level:metadata.Sc_rollup_metadata_repr.origination_level\n ~dal_attestation_lag\n ~commit_level\n page_id\n then\n let* input =\n Dal_slot_repr.History.verify_proof\n dal_parameters\n page_id\n dal_snapshot\n proof\n in\n return_some (Sc_rollup_PVM_sig.Reveal (Dal_page input))\n else return_none\n\n let produce ~metadata ~dal_attestation_lag ~commit_level dal_parameters\n page_id ~page_info ~get_history confirmed_slots_history =\n let open Lwt_result_syntax in\n if\n page_level_is_valid\n ~origination_level:metadata.Sc_rollup_metadata_repr.origination_level\n ~dal_attestation_lag\n ~commit_level\n page_id\n then\n let* proof, content_opt =\n Dal_slot_repr.History.produce_proof\n dal_parameters\n page_id\n ~page_info\n ~get_history\n confirmed_slots_history\n in\n return\n ( Some (Reveal_proof (Dal_page_proof {proof; page_id})),\n Some (Sc_rollup_PVM_sig.Reveal (Dal_page content_opt)) )\n else return (None, None)\nend\n\nlet valid (type state proof output)\n ~(pvm : (state, proof, output) Sc_rollups.PVM.implementation) ~metadata\n snapshot commit_inbox_level dal_snapshot dal_parameters ~dal_attestation_lag\n (proof : proof t) =\n let open Lwt_result_syntax in\n let (module P) = pvm in\n let origination_level = metadata.Sc_rollup_metadata_repr.origination_level in\n let* input =\n match proof.input_proof with\n | None -> return_none\n | Some (Inbox_proof {level; message_counter; proof}) ->\n let*? inbox_message =\n check_inbox_proof snapshot proof (level, Z.succ message_counter)\n in\n return\n @@ Option.map (fun i -> Sc_rollup_PVM_sig.Inbox_message i) inbox_message\n | Some First_inbox_message ->\n let*? payload =\n Sc_rollup_inbox_message_repr.(serialize (Internal Start_of_level))\n in\n let inbox_level = Raw_level_repr.succ origination_level in\n let message_counter = Z.zero in\n return_some\n Sc_rollup_PVM_sig.(\n Inbox_message {inbox_level; message_counter; payload})\n | Some (Reveal_proof (Raw_data_proof data)) ->\n return_some (Sc_rollup_PVM_sig.Reveal (Raw_data data))\n | Some (Reveal_proof Metadata_proof) ->\n return_some (Sc_rollup_PVM_sig.Reveal (Metadata metadata))\n | Some (Reveal_proof (Dal_page_proof {proof; page_id})) ->\n Dal_proofs.verify\n ~metadata\n dal_parameters\n ~dal_attestation_lag\n ~commit_level:commit_inbox_level\n page_id\n dal_snapshot\n proof\n |> Lwt.return\n in\n let input =\n Option.bind input (cut_at_level ~origination_level ~commit_inbox_level)\n in\n let* input_requested = P.verify_proof input proof.pvm_step in\n let* () =\n match (proof.input_proof, input_requested) with\n | None, No_input_required -> return_unit\n | Some First_inbox_message, Initial ->\n (* If the state is [Initial], we don't need a proof of the input,\n we know it's the [Start_of_level] after the origination. *)\n return_unit\n | Some (Inbox_proof {level; message_counter; proof = _}), First_after (l, n)\n ->\n check\n (Raw_level_repr.(level = l) && Z.(equal message_counter n))\n \"Level and index of inbox proof are not equal to the one expected in \\\n input request.\"\n | ( Some (Reveal_proof (Raw_data_proof data)),\n Needs_reveal (Reveal_raw_data expected_hash) ) ->\n let scheme = Sc_rollup_reveal_hash.scheme_of_hash expected_hash in\n\n let data_hash = Sc_rollup_reveal_hash.hash_string ~scheme [data] in\n check\n (Sc_rollup_reveal_hash.equal data_hash expected_hash)\n \"Invalid reveal\"\n | Some (Reveal_proof Metadata_proof), Needs_reveal Reveal_metadata ->\n return_unit\n | ( Some (Reveal_proof (Dal_page_proof {page_id; proof = _})),\n Needs_reveal (Request_dal_page pid) ) ->\n check\n (Dal_slot_repr.Page.equal page_id pid)\n \"Dal proof's page ID is not the one expected in input request.\"\n | None, (Initial | First_after _ | Needs_reveal _)\n | Some _, No_input_required\n | Some (Inbox_proof _), Needs_reveal _\n | _ ->\n proof_error \"Inbox proof and input request are dissociated.\"\n in\n return (input, input_requested)\n\nmodule type PVM_with_context_and_state = sig\n include Sc_rollups.PVM.S\n\n val context : context\n\n val state : state\n\n val proof_encoding : proof Data_encoding.t\n\n val reveal : Sc_rollup_reveal_hash.t -> string option Lwt.t\n\n module Inbox_with_history : sig\n val inbox : Sc_rollup_inbox_repr.history_proof\n\n val get_history :\n Sc_rollup_inbox_repr.Hash.t ->\n Sc_rollup_inbox_repr.history_proof option Lwt.t\n\n val get_payloads_history :\n Sc_rollup_inbox_merkelized_payload_hashes_repr.Hash.t ->\n Sc_rollup_inbox_merkelized_payload_hashes_repr.History.t Lwt.t\n end\n\n module Dal_with_history : sig\n val confirmed_slots_history : Dal_slot_repr.History.t\n\n val get_history :\n Dal_slot_repr.History.hash -> Dal_slot_repr.History.t option Lwt.t\n\n val page_info :\n (Dal_slot_repr.Page.content * Dal_slot_repr.Page.proof) option\n\n val dal_parameters : Dal_slot_repr.parameters\n\n val dal_attestation_lag : int\n end\nend\n\nlet produce ~metadata pvm_and_state commit_inbox_level =\n let open Lwt_result_syntax in\n let (module P : PVM_with_context_and_state) = pvm_and_state in\n let open P in\n let*! (request : Sc_rollup_PVM_sig.input_request) =\n P.is_input_state P.state\n in\n let origination_level = metadata.Sc_rollup_metadata_repr.origination_level in\n let* input_proof, input_given =\n match request with\n | No_input_required -> return (None, None)\n | Initial ->\n (* The first input of a rollup is the [Start_of_level] after its\n origination. *)\n let* input =\n let*? payload =\n Sc_rollup_inbox_message_repr.(serialize (Internal Start_of_level))\n in\n let inbox_level = Raw_level_repr.succ origination_level in\n let message_counter = Z.zero in\n return_some\n Sc_rollup_PVM_sig.(\n Inbox_message {inbox_level; message_counter; payload})\n in\n let inbox_proof = First_inbox_message in\n return (Some inbox_proof, input)\n | First_after (level, message_counter) ->\n let* inbox_proof, input =\n Inbox_with_history.(\n Sc_rollup_inbox_repr.produce_proof\n ~get_payloads_history\n ~get_history\n inbox\n (level, Z.succ message_counter))\n in\n let input =\n Option.map (fun msg -> Sc_rollup_PVM_sig.Inbox_message msg) input\n in\n let inbox_proof =\n Inbox_proof\n {\n level;\n message_counter;\n proof = Sc_rollup_inbox_repr.to_serialized_proof inbox_proof;\n }\n in\n return (Some inbox_proof, input)\n | Needs_reveal (Reveal_raw_data h) -> (\n let*! res = reveal h in\n match res with\n | None -> proof_error \"No reveal\"\n | Some data ->\n return\n ( Some (Reveal_proof (Raw_data_proof data)),\n Some (Sc_rollup_PVM_sig.Reveal (Raw_data data)) ))\n | Needs_reveal Reveal_metadata ->\n return\n ( Some (Reveal_proof Metadata_proof),\n Some Sc_rollup_PVM_sig.(Reveal (Metadata metadata)) )\n | Needs_reveal (Request_dal_page page_id) ->\n let open Dal_with_history in\n Dal_proofs.produce\n ~metadata\n dal_parameters\n ~dal_attestation_lag\n ~commit_level:commit_inbox_level\n page_id\n ~page_info\n ~get_history\n confirmed_slots_history\n in\n let input_given =\n Option.bind\n input_given\n (cut_at_level ~origination_level ~commit_inbox_level)\n in\n let* pvm_step_proof = P.produce_proof P.context input_given P.state in\n let*? pvm_step = serialize_pvm_step ~pvm:(module P) pvm_step_proof in\n return {pvm_step; input_proof}\n\nmodule Internal_for_tests = struct\n let cut_at_level = cut_at_level\nend\n" ;
} ;
{ name = "Skip_list_costs" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** [model_next ~length] returns the gas cost of inserting a cell in a\n skip list of a given [length], assuming basis equals 2. *)\nval model_next : length:Z.t -> Saturation_repr.may_saturate Saturation_repr.t\n\n(** [model_hash_cell ~backpointers_count] returns the gas cost of\n hashing the last cell with a given [backpointers_count], assuming\n basis equals 2. *)\nval model_hash_cell :\n backpointers_count:int -> Saturation_repr.may_saturate Saturation_repr.t\n\n(** [model_hash_cell_computed_backpointers_count ~index] same as\n {!model_hash_cell} but compute the number of backpointers a specific cell\n will have. Assuming basis equals 2. *)\nval model_hash_cell_computed_backpointers_count :\n index:Z.t -> Saturation_repr.may_saturate Saturation_repr.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule S = Saturation_repr\n\n(* Inferred from model model_next in file skip_list_benchmarks.ml *)\n(* fun size -> (19.813850951 * (log2 (1 + size))) *)\nlet model_next ~length =\n let open S.Syntax in\n let length = S.safe_z length in\n S.safe_int 20 * log2 (S.safe_int 1 + length)\n\n(* Inferred from model proto/alpha/skip_list/hash_cell in file\n skip_list_benchmarks.ml *)\n(* fun size -> (242.202299543 + (56.9693504823 * size)) *)\nlet model_hash_cell backpointers_count =\n let open S.Syntax in\n S.safe_int 250 + (S.safe_int 57 * backpointers_count)\n\nlet model_hash_cell_computed_backpointers_count ~index =\n model_hash_cell (S.Syntax.log2 (S.safe_z index))\n\nlet model_hash_cell ~backpointers_count =\n model_hash_cell (S.safe_int backpointers_count)\n" ;
} ;
{ name = "Sc_rollup_costs" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module contains constants and utility functions for gas metering\n functions used when handling SC rollups operations in context. *)\n\nmodule Constants : sig\n val cost_serialize_state_hash : Gas_limit_repr.cost\n\n val cost_serialize_commitment_hash : Gas_limit_repr.cost\n\n val cost_serialize_commitment : Gas_limit_repr.cost\n\n val cost_serialize_nonce : Gas_limit_repr.cost\nend\n\n(** [is_valid_parameters_ty_cost ty] returns the cost of checking whether a type\n is a valid sc rollup parameter. *)\nval is_valid_parameters_ty_cost :\n ty_size:'a Saturation_repr.t -> Saturation_repr.may_saturate Saturation_repr.t\n\n(** [cost_serialize_internal_inbox_message internal_inbox_message] is the cost\n of the serialization of an internal inbox message. It's equal to the cost of\n serializing the script expression, with {!Script_repr.force_bytes_cost} plus\n a fixed amount for the serialized addresses.\n\n It traverses the payload expression to find the precise cost. It is safe to\n use {!Script_repr.force_bytes_cost} because the payload of an internal inbox\n message is bounded.\n*)\nval cost_serialize_internal_inbox_message :\n Sc_rollup_inbox_message_repr.internal_inbox_message -> Gas_limit_repr.cost\n\n(** [cost_deserialize_output_proof ~bytes_len] is the cost of the\n deserialization of an output proof. It's equal to the cost of deserializing\n a script expression of size [bytes_len]. *)\nval cost_deserialize_output_proof : bytes_len:int -> Gas_limit_repr.cost\n\n(** [cost_serialize_external_inbox_message ~bytes_len] is the cost of the\n serialization of an external inbox message of length [bytes_len]. It is\n equal to the estimated cost of encoding a byte multiplied by [bytes_len]. *)\nval cost_serialize_external_inbox_message : bytes_len:int -> Gas_limit_repr.cost\n\n(** [cost_hash_bytes ~bytes_len] is the cost of hashing [bytes_len] bytes. *)\nval cost_hash_bytes : bytes_len:int -> Gas_limit_repr.cost\n\n(** [cost_check_dissection ~number_of_states ~tick_size ~hash_size] is the cost\n of checking that a dissection with a given [number_of_states] used in a\n refutation game is well-formed. This includes the comparison of a linear\n number of ticks as well as the verification of two hashes of given\n [hash_size]. *)\nval cost_check_dissection :\n number_of_states:int -> tick_size:int -> hash_size:int -> Gas_limit_repr.cost\n\n(** [cost_verify_output_proof ~bytes_len] is the cost of verifying an output\n proof of length [bytes_len]. *)\nval cost_verify_output_proof : bytes_len:int -> Gas_limit_repr.cost\n\n(** [cost_add_message ~new_cell_index ~msg_len] returns the cost of adding a\n message of length [msg_len] to a sc-rollup inbox. This function is used\n internally in the [Sc_rollup_storage] module and covers the function\n {!Sc_rollup_inbox_merkelized_payload_hashes_repr.add_payload *)\nval cost_add_message : current_index:Z.t -> msg_len:int -> Gas_limit_repr.cost\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule S = Saturation_repr\n\nmodule Constants = struct\n (* equal to Michelson_v1_gas.Cost_of.Unparsing.contract_optimized *)\n let cost_decoding_contract_optimized = S.safe_int 70\n\n (* equal to Michelson_v1_gas.Cost_of.Unparsing.key_hash_optimized *)\n let cost_decoding_key_hash_optimized = S.safe_int 70\n\n (* Set to the cost of encoding a pkh defined in {!Michelson_v1_gas} divided\n by the number of characters of a pkh, with the result rounded up, i.e.\n 70/20 + 1.\n To be updated when benchmarking is completed. *)\n let cost_encode_string_per_byte = S.safe_int 4\n\n (* Cost of serializing a state hash. *)\n let cost_serialize_state_hash =\n let len = S.safe_int State_hash.size in\n S.Syntax.(cost_encode_string_per_byte * len)\n\n (* Cost of serializing a commitment hash. *)\n let cost_serialize_commitment_hash =\n let len = S.safe_int Sc_rollup_commitment_repr.Hash.size in\n S.Syntax.(cost_encode_string_per_byte * len)\n\n (* Cost of serializing a commitment. The cost of serializing the level and\n number of ticks (both int32) is negligible. *)\n let cost_serialize_commitment =\n S.Syntax.(cost_serialize_state_hash + cost_serialize_commitment_hash)\n\n (* Cost of serializing an operation hash. *)\n let cost_serialize_operation_hash =\n let len = S.safe_int Operation_hash.size in\n S.Syntax.(cost_encode_string_per_byte * len)\n\n (* Cost of serializing a nonce. The cost of serializing the index (an int32)\n is negligible. *)\n let cost_serialize_nonce = cost_serialize_operation_hash\nend\n\n(* Reusing model from {!Ticket_costs.has_tickets_of_ty_cost}. *)\nlet is_valid_parameters_ty_cost ~ty_size =\n let fixed_cost = S.safe_int 10 in\n let coeff = S.safe_int 6 in\n S.add fixed_cost (S.mul coeff ty_size)\n\nlet cost_serialize_internal_inbox_message\n (internal_inbox_message :\n Sc_rollup_inbox_message_repr.internal_inbox_message) =\n match internal_inbox_message with\n | Transfer {payload; sender = _; source = _; destination = _} ->\n let lexpr = Script_repr.lazy_expr payload in\n let expr_cost = Script_repr.force_bytes_cost lexpr in\n S.Syntax.(\n expr_cost + Constants.cost_decoding_contract_optimized\n + Constants.cost_decoding_key_hash_optimized)\n | Start_of_level -> Saturation_repr.zero\n | End_of_level -> Saturation_repr.zero\n | Info_per_level _ -> Saturation_repr.zero\n\n(* Derived from benchmark in\n [Sc_rollup_benchmarks.Sc_rollup_deserialize_output_proof_benchmark] and model\n [model_Sc_rollup_deserialize_output_proof_benchmark]. *)\n(* fun size -> (7086.16259141 + (6.04996016914 * size)) *)\nlet cost_deserialize_output_proof ~bytes_len =\n let open S.Syntax in\n let v0 = S.safe_int bytes_len in\n S.safe_int 7100 + ((v0 lsl 2) + (v0 lsl 1))\n\nlet cost_serialize_external_inbox_message ~bytes_len =\n let len = S.safe_int bytes_len in\n S.Syntax.(Constants.cost_encode_string_per_byte * len)\n\n(* Equal to Michelson_v1_gas.Cost_of.Interpreter.blake2b. *)\nlet cost_hash_bytes ~bytes_len =\n let open S.Syntax in\n let v0 = S.safe_int bytes_len in\n S.safe_int 430 + v0 + (v0 lsr 3)\n\nlet cost_compare a_size_in_bytes b_size_in_bytes =\n let open S.Syntax in\n let size_in_bytes = Compare.Int.min a_size_in_bytes b_size_in_bytes in\n let v0 = S.safe_int size_in_bytes in\n S.safe_int 35 + ((v0 lsr 6) + (v0 lsr 7))\n\nlet cost_search_in_tick_list len tick_size =\n let open S.Syntax in\n S.safe_int len * cost_compare tick_size tick_size\n\nlet cost_check_dissection ~number_of_states ~tick_size ~hash_size =\n let open S.Syntax in\n cost_search_in_tick_list number_of_states tick_size\n + (S.safe_int 2 * cost_compare hash_size hash_size)\n\nlet cost_add_message ~current_index ~msg_len =\n let open S.Syntax in\n let hash_cell_cost =\n Skip_list_costs.model_hash_cell_computed_backpointers_count\n ~index:current_index\n in\n let hash_content_cost = cost_hash_bytes ~bytes_len:msg_len in\n let next_cell_cost =\n Skip_list_costs.model_next ~length:(Z.succ current_index)\n in\n hash_cell_cost + hash_content_cost + next_cell_cost\n\n(* Derived from benchmark in\n [Sc_rollup_benchmarks.Sc_rollup_verify_output_proof_benchmark] and model\n [model_Sc_rollup_verify_output_proof_benchmark] with estimated parameters:\n [fun size -> (103413.141163 + (6.85566158429 * size))] *)\nlet cost_verify_output_proof ~bytes_len =\n let open S.Syntax in\n let size = S.safe_int bytes_len in\n let v0 = size in\n S.safe_int 103450 + (v0 lsl 2) + (v0 lsl 1) + v0\n" ;
} ;
{ name = "Sc_rollup_game_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** The smart contract rollup refutation game types are defined here, as\n well as the basic pure logic for:\n\n - how to create a new game from a pair of commits in the commit tree;\n\n - how to update a game or complete a game when a move is played.\n\n This game logic is used by the protocol when two commitments are in\n conflict to determine which one of the commitments is wrong.\n\n Game state and moves\n ====================\n\n The first step consists of dissecting the commitment's number of ticks.\n The game stores a list [dissection] of state hashes and tick counts.\n These are the claims about the PVM history made by the player who has\n just moved.\n\n The next player to move will specify a tick count which appears in\n the [dissection]; this is the last of the state hashes which she\n agrees with. She will then either:\n\n - provide a new [dissection] by giving a list of state hashes and\n tick counts that starts at the chosen tick count and ends at the\n next tick count in the previous [dissection]. It must agree at the\n start but disagree with the final state.\n\n - if the tick difference between this state and the next is one,\n there is no 'room' for a new [dissection]. In this case she must\n provide a Merkle proof that shows the step in the current\n [dissection] is invalid.\n\n If a player failed to prove that the current [dissection] is valid.\n We reach the final move of the game. The other player will have\n a chance to prove that the [dissection] is valid.\n If both player fails to invalidate each other, the game ends in a draw.\n\n Initializing a game\n ===================\n\n In order to trigger the start of a game, one player must publish a\n first move.\n\n The [initial] function is called at this point. It converts a\n parent-child pair of commitments (belonging to the other player) into\n an initial [dissection]. The first move is immediately applied to\n this to give the first state of the game.\n\n Note: it is quite possible for the game to end immediately after\n this first move, either if the commitment has a tick count of one or\n more probably if the refutation proves that the commitment was\n 'premature' (the state is not blocked---there are further\n computation steps to do or more inbox messages to read).\n\n Expected properties\n ===================\n\n P1 - If [dissection] is honest, the next move must be dishonest:\n\n There is only one honest state hash for a given tick count. The\n next player must provide a different hash to the honest hash in\n the [dissection].\n\n P2 - If [dissection] is dishonest, there is a strategy for a player\n equipped with a perfect PVM to play an honest next move:\n\n The player with a perfect PVM can calculate honest hashes until\n one disagrees with the [dissection], and challenges the dissection\n at that point, publishing either an honest [dissection] or an\n honest [Proof].\n\n Each [dissection] has a maximum tick count step shorter than the\n last, so by induction using P1 and P2 we have\n\n P1' - If [dissection] is honest, the last player has a winning\n strategy.\n\n P2' - If [dissection] is dishonest, the next player has a winning\n strategy.\n\n This allows us to see the following. (We use [refuter] to mean the\n first player to move, and [defender] to mean the other player.)\n\n Honest refuter wins:\n An honest refuter will be refuting a dishonest commitment, because\n there is only one honest state possible per level. Therefore the\n initial [dissection] will be dishonest. By P2' the refuter has a\n winning strategy.\n\n Honest defender wins:\n An honest defender will have made an honest commitment which will\n be translated into an honest initial [dissection]. By P1' the\n defender has a winning strategy.\n\n*)\n\nopen Sc_rollup_repr\n\ntype error +=\n | Dissection_choice_not_found of Sc_rollup_tick_repr.t\n (** The given choice in a refutation is not a starting tick of any of\n the sections in the current dissection. *)\n | Proof_unexpected_section_size of Z.t\n (** Invalid proof step because there is more than one tick. *)\n | Proof_start_state_hash_mismatch of {\n start_state_hash : Sc_rollup_repr.State_hash.t option;\n start_proof : Sc_rollup_repr.State_hash.t;\n }\n (** The given proof's starting state doesn't match the expected one. *)\n | Proof_stop_state_hash_failed_to_refute of {\n stop_state_hash : Sc_rollup_repr.State_hash.t option;\n stop_proof : Sc_rollup_repr.State_hash.t option;\n }\n (** The given proof's ending state should not match the state being\n refuted. *)\n | Proof_stop_state_hash_failed_to_validate of {\n stop_state_hash : Sc_rollup_repr.State_hash.t option;\n stop_proof : Sc_rollup_repr.State_hash.t option;\n }\n (** The given proof's ending state should match the state being\n refuted. *)\n | Dissecting_during_final_move\n (** The step move is a dissecting where the final move has started\n already. *)\n\n(** The two stakers index the game in the storage as a pair of public\n key hashes which is in lexical order. We use [Alice] and [Bob] to\n represent the first and second player in the pair respectively. *)\ntype player = Alice | Bob\n\nmodule V1 : sig\n type dissection_chunk = Sc_rollup_dissection_chunk_repr.t\n\n (** Describes the current state of a game. *)\n type game_state =\n | Dissecting of {\n dissection : dissection_chunk list;\n (** [dissection], a list of states with tick counts. The current\n player will specify, in the next move, a tick count that\n indicates the last of these states that she agrees with. *)\n default_number_of_sections : int;\n (** [default_number_of_sections] is the number of sections a\n disection should contain in the more general case where we still\n have a high enough number of disputed ticks. *)\n }\n (** When the state is [Dissecting], both player are still dissecting\n the commitment to find the tick to refute. *)\n | Final_move of {\n agreed_start_chunk : dissection_chunk;\n refuted_stop_chunk : dissection_chunk;\n }\n (** When the state is [Final_move], either [Alice] or [Bob] already\n played an invalid proof.\n\n The other player will have a chance to prove that the\n [refuted_stop_state] is valid.\n If both players fail to either validate or refute the stop state,\n the current game state describes a draw situation.\n In the same way, the draw can be described by the situation where\n the two players manage to validate or refute the stop state. *)\n\n val game_state_encoding : game_state Data_encoding.t\n\n val game_state_equal : game_state -> game_state -> bool\n\n (** A game is characterized by:\n\n - [refuter_commitment_hash], the hash of the commitment of the player that\n has initiated the game.\n\n - [defender_commitment_hash], the hash of the commitment of the player that\n is tentatively refuted.\n\n - [turn], the player that must provide the next move.\n\n - [inbox_snapshot], a snapshot of the inbox state at the moment the\n game is created. This is only used when checking [Input_step] and\n [Blocked_step] proofs; it makes the proofs easier to create---\n otherwise they would have a 'moving target' because the actual\n inbox may be updated continuously.\n\n - [dal_snapshot], a snapshot of the DAL's confirmed slots history at the\n moment the game is created. In fact, since the confirmed slots history at\n initialization would likely evolve during the game, we need a (fixed)\n reference w.r.t. which Dal input proofs would be produced and verified if\n needed.\n\n - [level], the inbox level of the commitment the game is refuting.\n This is only used when checking [Blocked_step] proofs---the proof\n will show that the next message available in [inbox_snapshot] is\n at [level], so shouldn't be included in this commitment.\n\n - [game_state], the current state of the game, see {!game_state}\n for more information.\n\n Invariants:\n -----------\n - [dissection] must contain at least 2 values (normally it will be 32\n values, but smaller if there isn't enough space for a dissection\n that size. The initial game dissection will be 3 values except in\n the case of a zero-tick commit when it will have 2 values.)\n - the first state hash value in [dissection] must not be [None]\n - [inbox_snapshot] and [dal_snapshot] never change once the game is created\n *)\n type t = {\n turn : player;\n inbox_snapshot : Sc_rollup_inbox_repr.history_proof;\n dal_snapshot : Dal_slot_repr.History.t;\n start_level : Raw_level_repr.t;\n inbox_level : Raw_level_repr.t;\n game_state : game_state;\n }\n\n (** [equal g1 g2] returns [true] iff [g1] is equal to [g2]. *)\n val equal : t -> t -> bool\n\n (** Return the other player *)\n val opponent : player -> player\n\n val encoding : t Data_encoding.t\n\n val pp_dissection : Format.formatter -> dissection_chunk list -> unit\n\n val player_equal : player -> player -> bool\n\n val player_encoding : player Data_encoding.t\n\n val pp : Format.formatter -> t -> unit\nend\n\n(** Versioning, see {!Sc_rollup_data_version_sig.S} for more information. *)\ninclude Sc_rollup_data_version_sig.S with type t = V1.t\n\ninclude\n module type of V1\n with type dissection_chunk = V1.dissection_chunk\n and type game_state = V1.game_state\n and type t = V1.t\n\nmodule Index : sig\n type t = private {alice : Staker.t; bob : Staker.t}\n\n (** [to_path i p] returns a new path with the path to the game indexed\n by [i] added as a prefix to path [p]. See [Path_encoding] module. *)\n val to_path : t -> string list -> string list\n\n val of_path : string list -> t option\n\n val path_length : int\n\n val rpc_arg : t RPC_arg.t\n\n val encoding : t Data_encoding.t\n\n val compare : t -> t -> int\n\n val make : Staker.t -> Staker.t -> t\n\n (** Given an index in normal form, resolve a given [player] ([Alice]\n or [Bob]) to the actual staker they represent. *)\n val staker : t -> player -> Staker.t\nend\n\n(** To begin a game, first the conflict point in the commit tree is\n found, and then this function is applied.\n\n [initial inbox dal_slots_history ~start_level ~parent_commitment\n ~defender_commitment ~refuter ~defender ~default_number_of_sections] will\n construct an initial game where [refuter] is next to play. The game has\n [dissection] with three states:\n\n - firstly, the state (with tick zero) of [parent_commitment], the\n commitment that both stakers agree on.\n\n - secondly, the state and tick count of [defender_commitment], the\n commitment that [defender] has staked on.\n\n - thirdly, a [None] state which is a single tick after the\n [defender_commitment] commitment. This represents the claim, implicit in\n the commitment, that the state given is blocked.\n\n This gives [refuter] a binary choice: she can refute the commit\n itself by providing a new dissection between the two committed\n states, or she can refute the claim that the [child] commit is a\n blocked state by immediately providing a proof of a single tick\n increment from that state to its successor. *)\nval initial :\n Sc_rollup_inbox_repr.history_proof ->\n Dal_slot_repr.History.t ->\n start_level:Raw_level_repr.t ->\n parent_commitment:Sc_rollup_commitment_repr.t ->\n defender_commitment:Sc_rollup_commitment_repr.t ->\n refuter:Signature.public_key_hash ->\n defender:Signature.public_key_hash ->\n default_number_of_sections:int ->\n t\n\n(** A [step] in the game is either a new dissection (if there are\n intermediate ticks remaining to put in it) or a proof. *)\ntype step =\n | Dissection of dissection_chunk list\n | Proof of Sc_rollup_proof_repr.serialized Sc_rollup_proof_repr.t\n\n(** A [refutation] is a move in the game. *)\ntype refutation =\n | Start of {\n player_commitment_hash : Sc_rollup_commitment_repr.Hash.t;\n opponent_commitment_hash : Sc_rollup_commitment_repr.Hash.t;\n }\n | Move of {choice : Sc_rollup_tick_repr.t; step : step}\n (** [choice] is the final tick in the current dissection at which\n the two players agree. *)\n\nval pp_refutation : Format.formatter -> refutation -> unit\n\nval refutation_encoding : refutation Data_encoding.t\n\n(** A game ends for one of two reasons: the conflict has been\nresolved via a proof or a player has been timed out. *)\ntype reason = Conflict_resolved | Timeout\n\nval pp_reason : Format.formatter -> reason -> unit\n\nval reason_encoding : reason Data_encoding.t\n\n(** The game result. *)\ntype game_result =\n | Loser of {reason : reason; loser : Staker.t} (** One player lost. *)\n | Draw (** The game ended in a draw *)\n\nval pp_game_result : Format.formatter -> game_result -> unit\n\nval game_result_encoding : game_result Data_encoding.t\n\n(** A type that represents the current game status in a way that is\n useful to the outside world (using actual [Staker.t] values\n instead of the internal [player] type).\n\n The [Staker.t] in the [Ended] case is the loser of the game: the\n staker who will have their stake slashed.\n\n Used in operation result types. *)\ntype status = Ongoing | Ended of game_result\n\nval pp_status : Format.formatter -> status -> unit\n\nval status_encoding : status Data_encoding.t\n\n(** Decide the loser of the game, if it exists. *)\nval loser_of_results : alice_result:bool -> bob_result:bool -> player option\n\n(* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/3997\n Providing DAL parameters here is not resilient to their change during\n protocol upgrade. *)\n\n(** Applies the move [refutation] to the game. Returns the game {!status}\n after applying the move.\n\n In the case of the game continuing, this swaps the current\n player and returns a [Ongoing] status. Otherwise, it returns a\n [Ended <game_result>] status.\n\n The provided DAL parameters and [dal_attestation_lag] are used in case the\n game needs to check that a page's content is part of a slot (using the\n slot's commitment).\n*)\nval play :\n Sc_rollups.Kind.t ->\n Dal_slot_repr.parameters ->\n dal_attestation_lag:int ->\n stakers:Index.t ->\n Sc_rollup_metadata_repr.t ->\n t ->\n step:step ->\n choice:Sc_rollup_tick_repr.t ->\n (game_result, t) Either.t tzresult Lwt.t\n\n(** [cost_play ~step ~choice] returns the gas cost of [play] applied with[step],\n and [choice]. *)\nval cost_play : step:step -> choice:Sc_rollup_tick_repr.t -> Gas_limit_repr.cost\n\n(** A type that represents the number of blocks left for players to play. Each\n player has her timeout value. `timeout` is expressed in the number of\n blocks.\n\n Timeout logic is similar to a chess clock. Each player starts with the same\n timeout. Each game move updates the timeout of the current player by\n decreasing it by the amount of time she took to play, i.e. number of blocks\n since the opponent last move. See {!Sc_rollup_refutation_storage.game_move}\n to see the implementation.\n*)\ntype timeout = {\n alice : int; (** Timeout of [Alice]. *)\n bob : int; (** Timeout of [Bob]. *)\n last_turn_level : Raw_level_repr.t; (** Block level of the last turn move. *)\n}\n\nval timeout_encoding : timeout Data_encoding.t\n\nmodule Internal_for_tests : sig\n (** Checks that the tick count chosen by the current move is one of\n the ones in the current dissection. Returns a tuple containing\n the current dissection interval (including the two states) between\n this tick and the next. *)\n val find_choice :\n dissection_chunk list ->\n Sc_rollup_tick_repr.t ->\n (dissection_chunk * dissection_chunk) tzresult\n\n (** See {!Sc_rollup_dissection_chunk_repr.default_check} *)\n val check_dissection :\n default_number_of_sections:int ->\n start_chunk:dissection_chunk ->\n stop_chunk:dissection_chunk ->\n dissection_chunk list ->\n unit tzresult\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Sc_rollup_repr\n\n(** {2 Refutation game errors} *)\n\ntype error +=\n | (* `Temporary *)\n Dissection_choice_not_found of Sc_rollup_tick_repr.t\n | (* `Permanent *) Proof_unexpected_section_size of Z.t\n | (* `Temporary *)\n Proof_start_state_hash_mismatch of {\n start_state_hash : Sc_rollup_repr.State_hash.t option;\n start_proof : Sc_rollup_repr.State_hash.t;\n }\n | (* `Temporary *)\n Proof_stop_state_hash_failed_to_refute of {\n stop_state_hash : Sc_rollup_repr.State_hash.t option;\n stop_proof : Sc_rollup_repr.State_hash.t option;\n }\n | (* `Temporary *)\n Proof_stop_state_hash_failed_to_validate of {\n stop_state_hash : Sc_rollup_repr.State_hash.t option;\n stop_proof : Sc_rollup_repr.State_hash.t option;\n }\n | (* `Temporary *) Dissecting_during_final_move\n\nlet pp_hash_opt fmt = function\n | None -> Format.fprintf fmt \"None\"\n | Some x -> Sc_rollup_repr.State_hash.pp fmt x\n\nlet () =\n let description = \"Dissection choice not found\" in\n register_error_kind\n `Temporary\n ~id:\"Dissection_choice_not_found\"\n ~title:description\n ~description\n ~pp:(fun ppf choice ->\n Format.fprintf\n ppf\n \"No section starting with tick %a found\"\n Sc_rollup_tick_repr.pp\n choice)\n Data_encoding.(obj1 (req \"choice\" Sc_rollup_tick_repr.encoding))\n (function Dissection_choice_not_found tick -> Some tick | _ -> None)\n (fun tick -> Dissection_choice_not_found tick) ;\n let description = \"The distance for a proof should be equal to 1\" in\n register_error_kind\n `Permanent\n ~id:\"Dissection_unexpected_section_size\"\n ~title:description\n ~description\n ~pp:(fun ppf n ->\n Format.fprintf\n ppf\n \"Distance should be equal to 1 in a proof, but got %a\"\n Z.pp_print\n n)\n Data_encoding.(obj1 (req \"n\" n))\n (function Proof_unexpected_section_size n -> Some n | _ -> None)\n (fun n -> Proof_unexpected_section_size n) ;\n let description = \"The start state hash of the proof is invalid\" in\n register_error_kind\n `Temporary\n ~id:\"Proof_start_state_hash_mismatch\"\n ~title:description\n ~description\n ~pp:(fun ppf (start_state_hash, start_proof) ->\n Format.fprintf\n ppf\n \"start(%a) should be equal to start_proof(%a)\"\n pp_hash_opt\n start_state_hash\n Sc_rollup_repr.State_hash.pp\n start_proof)\n Data_encoding.(\n obj2\n (req \"start_state_hash\" (option Sc_rollup_repr.State_hash.encoding))\n (req \"start_proof\" Sc_rollup_repr.State_hash.encoding))\n (function\n | Proof_start_state_hash_mismatch {start_state_hash; start_proof} ->\n Some (start_state_hash, start_proof)\n | _ -> None)\n (fun (start_state_hash, start_proof) ->\n Proof_start_state_hash_mismatch {start_state_hash; start_proof}) ;\n let description = \"Failed to refute the stop state hash with the proof\" in\n register_error_kind\n `Temporary\n ~id:\"Proof_stop_state_hash_failed_to_refute\"\n ~title:description\n ~description\n ~pp:(fun ppf (stop_state_hash, stop_proof) ->\n Format.fprintf\n ppf\n \"Trying to refute %a, the stop_proof must not be equal to %a\"\n pp_hash_opt\n stop_state_hash\n pp_hash_opt\n stop_proof)\n Data_encoding.(\n obj2\n (req \"stop_state_hash\" (option Sc_rollup_repr.State_hash.encoding))\n (req \"stop_proof\" (option Sc_rollup_repr.State_hash.encoding)))\n (function\n | Proof_stop_state_hash_failed_to_refute {stop_state_hash; stop_proof} ->\n Some (stop_state_hash, stop_proof)\n | _ -> None)\n (fun (stop_state_hash, stop_proof) ->\n Proof_stop_state_hash_failed_to_refute {stop_state_hash; stop_proof}) ;\n let description = \"Failed to validate the stop state hash with the proof\" in\n register_error_kind\n `Temporary\n ~id:\"Proof_stop_state_hash_failed_to_validate\"\n ~title:description\n ~description\n ~pp:(fun ppf (stop_state_hash, stop_proof) ->\n Format.fprintf\n ppf\n \"Trying to validate %a, the stop_proof must not be equal to %a\"\n pp_hash_opt\n stop_state_hash\n pp_hash_opt\n stop_proof)\n Data_encoding.(\n obj2\n (req \"stop_state_hash\" (option Sc_rollup_repr.State_hash.encoding))\n (req \"stop_proof\" (option Sc_rollup_repr.State_hash.encoding)))\n (function\n | Proof_stop_state_hash_failed_to_validate {stop_state_hash; stop_proof}\n ->\n Some (stop_state_hash, stop_proof)\n | _ -> None)\n (fun (stop_state_hash, stop_proof) ->\n Proof_stop_state_hash_failed_to_validate {stop_state_hash; stop_proof}) ;\n let description = \"Tried to play a dissecting when the final move started\" in\n register_error_kind\n `Temporary\n ~id:\"Dissecting_during_final_move\"\n ~title:description\n ~description\n ~pp:(fun ppf () -> Format.pp_print_string ppf description)\n Data_encoding.empty\n (function Dissecting_during_final_move -> Some () | _ -> None)\n (fun () -> Dissecting_during_final_move) ;\n ()\n\ntype player = Alice | Bob\n\nmodule V1 = struct\n type dissection_chunk = Sc_rollup_dissection_chunk_repr.t = {\n state_hash : State_hash.t option;\n tick : Sc_rollup_tick_repr.t;\n }\n\n type game_state =\n | Dissecting of {\n dissection : dissection_chunk list;\n default_number_of_sections : int;\n }\n | Final_move of {\n agreed_start_chunk : dissection_chunk;\n refuted_stop_chunk : dissection_chunk;\n }\n\n type t = {\n turn : player;\n inbox_snapshot : Sc_rollup_inbox_repr.history_proof;\n dal_snapshot : Dal_slot_repr.History.t;\n start_level : Raw_level_repr.t;\n inbox_level : Raw_level_repr.t;\n game_state : game_state;\n }\n\n let player_encoding =\n let open Data_encoding in\n union\n ~tag_size:`Uint8\n [\n case\n ~title:\"Alice\"\n (Tag 0)\n (constant \"alice\")\n (function Alice -> Some () | _ -> None)\n (fun () -> Alice);\n case\n ~title:\"Bob\"\n (Tag 1)\n (constant \"bob\")\n (function Bob -> Some () | _ -> None)\n (fun () -> Bob);\n ]\n\n let player_equal p1 p2 =\n match (p1, p2) with\n | Alice, Alice -> true\n | Bob, Bob -> true\n | _, _ -> false\n\n let game_state_equal gs1 gs2 =\n match (gs1, gs2) with\n | ( Dissecting\n {\n dissection = dissection1;\n default_number_of_sections = default_number_of_sections1;\n },\n Dissecting\n {\n dissection = dissection2;\n default_number_of_sections = default_number_of_sections2;\n } ) ->\n Compare.Int.equal\n default_number_of_sections1\n default_number_of_sections2\n && List.equal\n Sc_rollup_dissection_chunk_repr.equal\n dissection1\n dissection2\n | Dissecting _, _ -> false\n | ( Final_move\n {\n agreed_start_chunk = agreed_start_chunk1;\n refuted_stop_chunk = refuted_stop_chunk1;\n },\n Final_move\n {\n agreed_start_chunk = agreed_start_chunk2;\n refuted_stop_chunk = refuted_stop_chunk2;\n } ) ->\n Sc_rollup_dissection_chunk_repr.equal\n agreed_start_chunk1\n agreed_start_chunk2\n && Sc_rollup_dissection_chunk_repr.equal\n refuted_stop_chunk1\n refuted_stop_chunk2\n | Final_move _, _ -> false\n\n let equal\n {turn; inbox_snapshot; dal_snapshot; start_level; inbox_level; game_state}\n g2 =\n player_equal turn g2.turn\n && Sc_rollup_inbox_repr.equal_history_proof inbox_snapshot g2.inbox_snapshot\n && Dal_slot_repr.History.equal dal_snapshot g2.dal_snapshot\n && Raw_level_repr.equal start_level g2.start_level\n && Raw_level_repr.equal inbox_level g2.inbox_level\n && game_state_equal game_state g2.game_state\n\n let string_of_player = function Alice -> \"alice\" | Bob -> \"bob\"\n\n let pp_player ppf player =\n Format.pp_print_string ppf (string_of_player player)\n\n let opponent = function Alice -> Bob | Bob -> Alice\n\n let dissection_encoding =\n let open Data_encoding in\n list Sc_rollup_dissection_chunk_repr.encoding\n\n let game_state_encoding =\n let open Data_encoding in\n union\n ~tag_size:`Uint8\n [\n case\n ~title:\"Dissecting\"\n (Tag 0)\n (obj3\n (req \"kind\" (constant \"Dissecting\"))\n (req \"dissection\" dissection_encoding)\n (req \"default_number_of_sections\" uint8))\n (function\n | Dissecting {dissection; default_number_of_sections} ->\n Some ((), dissection, default_number_of_sections)\n | _ -> None)\n (fun ((), dissection, default_number_of_sections) ->\n Dissecting {dissection; default_number_of_sections});\n case\n ~title:\"Final_move\"\n (Tag 1)\n (obj3\n (req \"kind\" (constant \"Final_move\"))\n (req \"agreed_start_chunk\" Sc_rollup_dissection_chunk_repr.encoding)\n (req \"refuted_stop_chunk\" Sc_rollup_dissection_chunk_repr.encoding))\n (function\n | Final_move {agreed_start_chunk; refuted_stop_chunk} ->\n Some ((), agreed_start_chunk, refuted_stop_chunk)\n | _ -> None)\n (fun ((), agreed_start_chunk, refuted_stop_chunk) ->\n Final_move {agreed_start_chunk; refuted_stop_chunk});\n ]\n\n let encoding =\n let open Data_encoding in\n conv\n (fun {\n turn;\n inbox_snapshot;\n dal_snapshot;\n start_level;\n inbox_level;\n game_state;\n } ->\n ( turn,\n inbox_snapshot,\n dal_snapshot,\n start_level,\n inbox_level,\n game_state ))\n (fun ( turn,\n inbox_snapshot,\n dal_snapshot,\n start_level,\n inbox_level,\n game_state ) ->\n {\n turn;\n inbox_snapshot;\n dal_snapshot;\n start_level;\n inbox_level;\n game_state;\n })\n (obj6\n (req \"turn\" player_encoding)\n (req \"inbox_snapshot\" Sc_rollup_inbox_repr.history_proof_encoding)\n (req \"dal_snapshot\" Dal_slot_repr.History.encoding)\n (req \"start_level\" Raw_level_repr.encoding)\n (req \"inbox_level\" Raw_level_repr.encoding)\n (req \"game_state\" game_state_encoding))\n\n let pp_dissection ppf d =\n Format.pp_print_list\n ~pp_sep:(fun ppf () -> Format.pp_print_string ppf \";\\n\")\n Sc_rollup_dissection_chunk_repr.pp\n ppf\n d\n\n let pp_game_state ppf game_state =\n let open Format in\n match game_state with\n | Dissecting {dissection; default_number_of_sections} ->\n fprintf\n ppf\n \"Dissecting %a using %d number of sections\"\n pp_dissection\n dissection\n default_number_of_sections\n | Final_move {agreed_start_chunk; refuted_stop_chunk} ->\n fprintf\n ppf\n \"Final move to refute %a from %a, opponent failed to refute\"\n Sc_rollup_dissection_chunk_repr.pp\n agreed_start_chunk\n Sc_rollup_dissection_chunk_repr.pp\n refuted_stop_chunk\n\n let pp ppf game =\n Format.fprintf\n ppf\n \"%a playing; inbox snapshot = %a; start level = %a; inbox level = %a; \\\n game_state = %a\"\n pp_player\n game.turn\n Sc_rollup_inbox_repr.pp_history_proof\n game.inbox_snapshot\n Raw_level_repr.pp\n game.start_level\n Raw_level_repr.pp\n game.inbox_level\n pp_game_state\n game.game_state\nend\n\ntype versioned = V1 of V1.t\n\nlet versioned_encoding =\n let open Data_encoding in\n union\n [\n case\n ~title:\"V1\"\n (Tag 0)\n V1.encoding\n (function V1 game -> Some game)\n (fun game -> V1 game);\n ]\n\ninclude V1\n\nlet of_versioned = function V1 game -> game [@@inline]\n\nlet to_versioned game = V1 game [@@inline]\n\nmodule Index = struct\n type t = {alice : Staker.t; bob : Staker.t}\n\n let make a b =\n let alice, bob =\n if Compare.Int.(Staker.compare a b > 0) then (b, a) else (a, b)\n in\n {alice; bob}\n\n let encoding =\n let open Data_encoding in\n conv\n (fun {alice; bob} -> (alice, bob))\n (fun (alice, bob) -> make alice bob)\n (obj2 (req \"alice\" Staker.encoding) (req \"bob\" Staker.encoding))\n\n let compare {alice = a; bob = b} {alice = c; bob = d} =\n match Staker.compare a c with 0 -> Staker.compare b d | x -> x\n\n let to_path {alice; bob} p =\n Staker.to_b58check alice :: Staker.to_b58check bob :: p\n\n let both_of_b58check_opt (a, b) =\n let ( let* ) = Option.bind in\n let* a_staker = Staker.of_b58check_opt a in\n let* b_staker = Staker.of_b58check_opt b in\n Some (make a_staker b_staker)\n\n let of_path = function [a; b] -> both_of_b58check_opt (a, b) | _ -> None\n\n let path_length = 2\n\n let rpc_arg =\n let descr =\n \"A pair of stakers that index a smart rollup refutation game.\"\n in\n let construct {alice; bob} =\n Format.sprintf \"%s-%s\" (Staker.to_b58check alice) (Staker.to_b58check bob)\n in\n let destruct s =\n match String.split_on_char '-' s with\n | [a; b] -> (\n match both_of_b58check_opt (a, b) with\n | Some stakers -> ok stakers\n | None ->\n Result.error (Format.sprintf \"Invalid game index notation %s\" s))\n | _ -> Result.error (Format.sprintf \"Invalid game index notation %s\" s)\n in\n RPC_arg.make ~descr ~name:\"game_index\" ~construct ~destruct ()\n\n let staker {alice; bob} = function Alice -> alice | Bob -> bob\nend\n\nlet make_chunk state_hash tick = {state_hash; tick}\n\nlet initial inbox dal_snapshot ~start_level\n ~(parent_commitment : Sc_rollup_commitment_repr.t)\n ~(defender_commitment : Sc_rollup_commitment_repr.t) ~refuter ~defender\n ~default_number_of_sections =\n let ({alice; _} : Index.t) = Index.make refuter defender in\n let alice_to_play = Staker.equal alice refuter in\n let open Sc_rollup_tick_repr in\n let tick = of_number_of_ticks defender_commitment.number_of_ticks in\n let game_state =\n Dissecting\n {\n dissection =\n [\n make_chunk (Some parent_commitment.compressed_state) initial;\n make_chunk (Some defender_commitment.compressed_state) tick;\n make_chunk None (next tick);\n ];\n default_number_of_sections;\n }\n in\n\n {\n turn = (if alice_to_play then Alice else Bob);\n inbox_snapshot = inbox;\n dal_snapshot;\n start_level;\n inbox_level = defender_commitment.inbox_level;\n game_state;\n }\n\ntype step =\n | Dissection of dissection_chunk list\n | Proof of Sc_rollup_proof_repr.serialized Sc_rollup_proof_repr.t\n\nlet step_encoding =\n let open Data_encoding in\n union\n ~tag_size:`Uint8\n [\n case\n ~title:\"Dissection\"\n (Tag 0)\n dissection_encoding\n (function Dissection d -> Some d | _ -> None)\n (fun d -> Dissection d);\n case\n ~title:\"Proof\"\n (Tag 1)\n Sc_rollup_proof_repr.encoding\n (function Proof p -> Some p | _ -> None)\n (fun p -> Proof p);\n ]\n\nlet pp_step ppf step =\n match step with\n | Dissection states ->\n Format.fprintf ppf \"Dissection:@ \" ;\n Format.pp_print_list\n ~pp_sep:(fun ppf () -> Format.pp_print_string ppf \";\\n\\n\")\n (fun ppf {state_hash; tick} ->\n Format.fprintf\n ppf\n \"Tick: %a,@ State: %a\\n\"\n Sc_rollup_tick_repr.pp\n tick\n (Format.pp_print_option State_hash.pp)\n state_hash)\n ppf\n states\n | Proof proof -> Format.fprintf ppf \"proof: %a\" Sc_rollup_proof_repr.pp proof\n\ntype refutation =\n | Start of {\n player_commitment_hash : Sc_rollup_commitment_repr.Hash.t;\n opponent_commitment_hash : Sc_rollup_commitment_repr.Hash.t;\n }\n | Move of {choice : Sc_rollup_tick_repr.t; step : step}\n\nlet pp_refutation ppf = function\n | Start {player_commitment_hash; opponent_commitment_hash} ->\n Format.fprintf\n ppf\n \"Start game between commitment hashes %a and %a\"\n Sc_rollup_commitment_repr.Hash.pp\n player_commitment_hash\n Sc_rollup_commitment_repr.Hash.pp\n opponent_commitment_hash\n | Move {choice; step} ->\n Format.fprintf\n ppf\n \"Tick: %a@ Step: %a\"\n Sc_rollup_tick_repr.pp\n choice\n pp_step\n step\n\nlet refutation_encoding =\n let open Data_encoding in\n union\n ~tag_size:`Uint8\n [\n case\n ~title:\"Start\"\n (Tag 0)\n (obj3\n (req \"refutation_kind\" (constant \"start\"))\n (req\n \"player_commitment_hash\"\n Sc_rollup_commitment_repr.Hash.encoding)\n (req\n \"opponent_commitment_hash\"\n Sc_rollup_commitment_repr.Hash.encoding))\n (function\n | Start {player_commitment_hash; opponent_commitment_hash} ->\n Some ((), player_commitment_hash, opponent_commitment_hash)\n | _ -> None)\n (fun ((), player_commitment_hash, opponent_commitment_hash) ->\n Start {player_commitment_hash; opponent_commitment_hash});\n case\n ~title:\"Move\"\n (Tag 1)\n (obj3\n (req \"refutation_kind\" (constant \"move\"))\n (req \"choice\" Sc_rollup_tick_repr.encoding)\n (req \"step\" step_encoding))\n (function Move {choice; step} -> Some ((), choice, step) | _ -> None)\n (fun ((), choice, step) -> Move {choice; step});\n ]\n\ntype reason = Conflict_resolved | Timeout\n\nlet pp_reason ppf reason =\n match reason with\n | Conflict_resolved -> Format.fprintf ppf \"conflict resolved\"\n | Timeout -> Format.fprintf ppf \"timeout\"\n\nlet reason_encoding =\n let open Data_encoding in\n union\n ~tag_size:`Uint8\n [\n case\n ~title:\"Conflict_resolved\"\n (Tag 0)\n (constant \"conflict_resolved\")\n (function Conflict_resolved -> Some () | _ -> None)\n (fun () -> Conflict_resolved);\n case\n ~title:\"Timeout\"\n (Tag 1)\n (constant \"timeout\")\n (function Timeout -> Some () | _ -> None)\n (fun () -> Timeout);\n ]\n\ntype game_result = Loser of {reason : reason; loser : Staker.t} | Draw\n\nlet pp_game_result ppf r =\n let open Format in\n match r with\n | Loser {reason; loser} ->\n fprintf ppf \"%a lost because: %a\" Staker.pp loser pp_reason reason\n | Draw -> fprintf ppf \"Draw\"\n\nlet game_result_encoding =\n let open Data_encoding in\n union\n ~tag_size:`Uint8\n [\n case\n ~title:\"Loser\"\n (Tag 0)\n (obj3\n (req \"kind\" (constant \"loser\"))\n (req \"reason\" reason_encoding)\n (req \"player\" Staker.encoding))\n (function\n | Loser {reason; loser} -> Some ((), reason, loser) | _ -> None)\n (fun ((), reason, loser) -> Loser {reason; loser});\n case\n ~title:\"Draw\"\n (Tag 1)\n (obj1 (req \"kind\" (constant \"draw\")))\n (function Draw -> Some () | _ -> None)\n (fun () -> Draw);\n ]\n\ntype status = Ongoing | Ended of game_result\n\nlet pp_status ppf status =\n match status with\n | Ongoing -> Format.fprintf ppf \"Game ongoing\"\n | Ended game_result ->\n Format.fprintf ppf \"Game ended: %a\" pp_game_result game_result\n\nlet status_encoding =\n let open Data_encoding in\n union\n ~tag_size:`Uint8\n [\n case\n ~title:\"Ongoing\"\n (Tag 0)\n (constant \"ongoing\")\n (function Ongoing -> Some () | _ -> None)\n (fun () -> Ongoing);\n case\n ~title:\"Ended\"\n (Tag 1)\n (obj1 (req \"result\" game_result_encoding))\n (function Ended r -> Some r | _ -> None)\n (fun r -> Ended r);\n ]\n\nlet find_choice dissection tick =\n let open Result_syntax in\n let rec traverse states =\n match states with\n | ({state_hash = _; tick = state_tick} as curr) :: next :: others ->\n if Sc_rollup_tick_repr.(tick = state_tick) then return (curr, next)\n else traverse (next :: others)\n | _ -> tzfail (Dissection_choice_not_found tick)\n in\n traverse dissection\n\n(** Check that the chosen interval is a single tick. *)\nlet check_proof_distance_is_one ~start_tick ~stop_tick =\n let dist = Sc_rollup_tick_repr.distance start_tick stop_tick in\n error_unless Z.(equal dist one) (Proof_unexpected_section_size dist)\n\n(** Check the proof begins with the correct state. *)\nlet check_proof_start_state ~pvm ~start_state proof =\n let start_proof = Sc_rollup_proof_repr.start_of_pvm_step ~pvm proof in\n error_unless\n (Option.equal State_hash.equal start_state (Some start_proof))\n (Proof_start_state_hash_mismatch\n {start_state_hash = start_state; start_proof})\n\n(** Check the proof stops with a different state than refuted one. *)\nlet check_proof_stop_state ~pvm ~stop_state input_given\n (input_request : Sc_rollup_PVM_sig.input_request) proof validate =\n let stop_proof =\n match (input_given, input_request) with\n | None, No_input_required\n | Some _, Initial\n | Some _, First_after _\n | Some _, Needs_reveal _ ->\n Some (Sc_rollup_proof_repr.stop_of_pvm_step ~pvm proof)\n | Some _, No_input_required\n | None, Initial\n | None, First_after _\n | None, Needs_reveal _ ->\n None\n in\n error_unless\n (let b = Option.equal State_hash.equal stop_state stop_proof in\n if validate then b else not b)\n (if validate then\n Proof_stop_state_hash_failed_to_validate\n {stop_state_hash = stop_state; stop_proof}\n else\n Proof_stop_state_hash_failed_to_refute\n {stop_state_hash = stop_state; stop_proof})\n\n(** Check the proof validates the stop state. *)\nlet check_proof_validate_stop_state ~stop_state input input_request proof =\n check_proof_stop_state ~stop_state input input_request proof true\n\n(** Check the proof refutes the stop state. *)\nlet check_proof_refute_stop_state ~stop_state input input_request proof =\n check_proof_stop_state ~stop_state input input_request proof false\n\n(** Returns the validity of the first final move on top of a dissection. *)\nlet validity_final_move ~pvm ~dal_parameters ~dal_attestation_lag ~first_move\n ~metadata ~proof ~game ~start_chunk ~stop_chunk =\n let open Lwt_result_syntax in\n let*! res =\n let {inbox_snapshot; inbox_level; dal_snapshot; _} = game in\n let*! valid =\n (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/3997\n This function is not resilient to dal parameters changes\n (cryptobox parameters or dal_attestation_lag for instance). *)\n Sc_rollup_proof_repr.valid\n ~pvm\n ~metadata\n inbox_snapshot\n inbox_level\n dal_snapshot\n dal_parameters\n ~dal_attestation_lag\n proof\n in\n let*? () =\n if first_move then\n check_proof_distance_is_one\n ~start_tick:start_chunk.tick\n ~stop_tick:stop_chunk.tick\n else ok ()\n in\n let*? () =\n check_proof_start_state\n ~pvm\n ~start_state:start_chunk.state_hash\n proof.pvm_step\n in\n match valid with\n | Ok (input, input_request) ->\n let*? () =\n if first_move then\n check_proof_refute_stop_state\n ~pvm\n ~stop_state:stop_chunk.state_hash\n input\n input_request\n proof.pvm_step\n else\n check_proof_validate_stop_state\n ~pvm\n ~stop_state:stop_chunk.state_hash\n input\n input_request\n proof.pvm_step\n in\n return_true\n | _ -> return_false\n in\n Lwt.return @@ Result.value ~default:false res\n\n(** Returns the validity of the first final move on top of a dissection.\n\n It is valid if and only:\n - The distance of the refuted dissection is [1].\n - The proof start on the agreed start state.\n - The proof stop on the state different than the refuted one.\n - The proof is correctly verified.\n*)\nlet validity_first_final_move ~pvm ~dal_parameters ~dal_attestation_lag\n ~metadata ~proof ~game ~start_chunk ~stop_chunk =\n validity_final_move\n ~pvm\n ~dal_parameters\n ~dal_attestation_lag\n ~first_move:true\n ~metadata\n ~proof\n ~game\n ~start_chunk\n ~stop_chunk\n\n(** Returns the validity of the second final move.\n\n It is valid if and only:\n - The proof start on the agreed start state.\n - The proof stop on the state validates the refuted one.\n - The proof is correctly verified.\n*)\nlet validity_second_final_move ~pvm ~dal_parameters ~dal_attestation_lag\n ~metadata ~agreed_start_chunk ~refuted_stop_chunk ~game ~proof =\n validity_final_move\n ~pvm\n ~dal_parameters\n ~dal_attestation_lag\n ~first_move:false\n ~metadata\n ~proof\n ~game\n ~start_chunk:agreed_start_chunk\n ~stop_chunk:refuted_stop_chunk\n\nlet loser_of_results ~alice_result ~bob_result =\n match (alice_result, bob_result) with\n | true, true -> None\n | false, false -> None\n | false, true -> Some Alice\n | true, false -> Some Bob\n\nlet cost_play ~step ~choice =\n match step with\n | Dissection states ->\n let number_of_states = List.length states in\n let hash_size = State_hash.size in\n let tick_size = Sc_rollup_tick_repr.size_in_bytes choice in\n Sc_rollup_costs.cost_check_dissection\n ~number_of_states\n ~tick_size\n ~hash_size\n | Proof _proof ->\n (*\n\n Proof verification is complex. We choose to follow a very\n rough overaproximation based on the idea that proof\n verification for both the inbox and the execution step is\n dominated by hash computation.\n\n Assuming that the worst case is a proof of the maximal\n operation data length, we consider the cost of hashing a\n balanced binary tree of this size (with a maximal size of\n leaves since the hashing of internal nodes can be neglected.\n\n We also consider the largest tick known. At the time of writing\n this comment, the largest tick is the origination tick of the\n PVM.\n\n If we assume the following worst-case for origination tick:\n - the origination has been done with a kernel of maximum size, and\n - most of the computation cost is consumed by importing this kernel\n in the PVM,\n\n We can simply consider, again, that the cost of hashing the imported\n kernel dominates everything else.\n\n We multiply this number by 10 for extra safety.\n\n At the time of writing this comment, this leads to 372940\n mgas for the proof wellformedness verification and 372940\n mgas for the cost of executing a tick.\n\n *)\n let open Saturation_repr in\n (* model N_IBlake2b *)\n (* Approximating 1.120804 x term *)\n let cost_N_IBlake2b size =\n let open Syntax in\n let v0 = safe_int size in\n safe_int 430 + v0 + (v0 lsr 3)\n in\n let overapproximated_hashing_size =\n 2 * Constants_repr.max_operation_data_length\n in\n let scale10 x = Saturation_repr.(mul (safe_int 10) x) in\n scale10 @@ Gas_limit_repr.atomic_step_cost\n @@ cost_N_IBlake2b overapproximated_hashing_size\n\nlet play kind dal_parameters ~dal_attestation_lag ~stakers metadata game ~step\n ~choice =\n let open Lwt_result_syntax in\n let (Packed ((module PVM) as pvm)) = Sc_rollups.Kind.pvm_of kind in\n let mk_loser loser =\n let loser = Index.staker stakers loser in\n Either.Left (Loser {loser; reason = Conflict_resolved})\n in\n match (step, game.game_state) with\n | Dissection states, Dissecting {dissection; default_number_of_sections} ->\n let*? start_chunk, stop_chunk = find_choice dissection choice in\n let*? () =\n PVM.check_dissection\n ~default_number_of_sections\n ~start_chunk\n ~stop_chunk\n states\n in\n let new_game_state =\n Dissecting {dissection = states; default_number_of_sections}\n in\n return\n (Either.Right\n {\n turn = opponent game.turn;\n inbox_snapshot = game.inbox_snapshot;\n dal_snapshot = game.dal_snapshot;\n start_level = game.start_level;\n inbox_level = game.inbox_level;\n game_state = new_game_state;\n })\n | Dissection _, Final_move _ -> tzfail Dissecting_during_final_move\n | Proof proof, Dissecting {dissection; default_number_of_sections = _} ->\n let*? start_chunk, stop_chunk = find_choice dissection choice in\n let*? pvm_step =\n Sc_rollup_proof_repr.unserialize_pvm_step ~pvm proof.pvm_step\n in\n let proof = {proof with pvm_step} in\n let*! player_result =\n validity_first_final_move\n ~pvm\n ~dal_parameters\n ~dal_attestation_lag\n ~proof\n ~metadata\n ~game\n ~start_chunk\n ~stop_chunk\n in\n if player_result then return @@ mk_loser (opponent game.turn)\n else\n let new_game_state =\n let agreed_start_chunk = start_chunk in\n let refuted_stop_chunk = stop_chunk in\n Final_move {agreed_start_chunk; refuted_stop_chunk}\n in\n return\n (Either.Right\n {\n turn = opponent game.turn;\n inbox_snapshot = game.inbox_snapshot;\n dal_snapshot = game.dal_snapshot;\n start_level = game.start_level;\n inbox_level = game.inbox_level;\n game_state = new_game_state;\n })\n | Proof proof, Final_move {agreed_start_chunk; refuted_stop_chunk} ->\n let*? pvm_step =\n Sc_rollup_proof_repr.unserialize_pvm_step ~pvm proof.pvm_step\n in\n let proof = {proof with pvm_step} in\n let*! player_result =\n validity_second_final_move\n ~pvm\n ~dal_parameters\n ~dal_attestation_lag\n ~metadata\n ~agreed_start_chunk\n ~refuted_stop_chunk\n ~game\n ~proof\n in\n if player_result then\n (* If we play when the final move started, the opponent provided\n a invalid proof. So if the defender manages to provide a valid\n proof, he wins. *)\n return @@ mk_loser (opponent game.turn)\n else return (Either.Left Draw)\n\nmodule Internal_for_tests = struct\n let find_choice = find_choice\n\n let check_dissection ~default_number_of_sections ~start_chunk ~stop_chunk =\n let open Sc_rollup_dissection_chunk_repr in\n let dist = Sc_rollup_tick_repr.distance start_chunk.tick stop_chunk.tick in\n let section_maximum_size = Z.div dist (Z.of_int 2) in\n Sc_rollup_dissection_chunk_repr.(\n default_check\n ~section_maximum_size\n ~check_sections_number:default_check_sections_number\n ~default_number_of_sections\n ~start_chunk\n ~stop_chunk)\nend\n\ntype timeout = {alice : int; bob : int; last_turn_level : Raw_level_repr.t}\n\nlet timeout_encoding =\n let open Data_encoding in\n conv\n (fun {alice; bob; last_turn_level} -> (alice, bob, last_turn_level))\n (fun (alice, bob, last_turn_level) -> {alice; bob; last_turn_level})\n (obj3\n (req \"alice\" int31)\n (req \"bob\" int31)\n (req \"last_turn_level\" Raw_level_repr.encoding))\n" ;
} ;
{ name = "Tx_rollup_level_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\ntype t\n\ntype level = t\n\n(** @raise Invalid_argument when the level to encode is not positive *)\nval encoding : level Data_encoding.t\n\nval rpc_arg : level RPC_arg.arg\n\nval pp : Format.formatter -> level -> unit\n\ninclude Compare.S with type t := level\n\nval to_int32 : level -> int32\n\n(** @raise Invalid_argument when the level to encode is negative *)\nval of_int32_exn : int32 -> level\n\n(** Can trigger Unexpected_level error when the level to encode is negative *)\nval of_int32 : int32 -> level tzresult\n\nval diff : level -> level -> int32\n\nval root : level\n\nval succ : level -> level\n\nval pred : level -> level option\n\n(** [add l i] i must be positive *)\nval add : level -> int -> level\n\n(** [sub l i] i must be positive *)\nval sub : level -> int -> level option\n\nmodule Index : Storage_description.INDEX with type t = level\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ninclude Raw_level_repr\n\ntype level = t\n" ;
} ;
{ name = "Tx_rollup_l2_proof" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxheadalpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(* The type of a Merkle proof for a L2 message *)\ntype t = Context.Proof.stream Context.Proof.t\n\nval encoding : t Data_encoding.t\n\n(** A compact binary representation of the proofs. *)\ntype serialized = private string\n\nval length : serialized -> int\n\nval serialized_encoding : serialized Data_encoding.t\n\nval proof_of_serialized_opt : serialized -> t option\n\nval serialize_proof_exn : t -> serialized\n\nmodule Internal_for_tests : sig\n (** [of_bytes] can be used to generate invalid serialized proofs,\n that cannot be turned into valid proofs. *)\n val of_bytes : bytes -> serialized\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxheadalpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t = Context.Proof.stream Context.Proof.t\n\nlet encoding = Context.Proof_encoding.V2.Tree2.stream_proof_encoding\n\ntype serialized = string\n\nlet length = String.length\n\nlet serialized_encoding = Data_encoding.(string Hex)\n\nlet proof_of_serialized_opt = Data_encoding.Binary.of_string_opt encoding\n\nlet serialize_proof_exn = Data_encoding.Binary.to_string_exn encoding\n\nmodule Internal_for_tests = struct\n let of_bytes = Bytes.to_string\nend\n" ;
} ;
{ name = "Tx_rollup_l2_address" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module introduces the types used to identify ticket holders\n within a transaction rollup. *)\n\n(** The hash of a BLS public key is used as the primary identifier\n of ticket holders within a transaction rollup. *)\ninclude module type of Bls.Public_key_hash with type t = Bls.Public_key_hash.t\n\ntype address = t\n\n(** [in_memory_size a] returns the number of bytes allocated in RAM for [a]. *)\nval in_memory_size : t -> Cache_memory_helpers.sint\n\n(** [size a] returns the number of bytes allocated in an inbox to store [a]. *)\nval size : t -> int\n\nmodule Indexable : sig\n type nonrec 'state t = ('state, address) Indexable.t\n\n type nonrec index = address Indexable.index\n\n type nonrec value = address Indexable.value\n\n type nonrec either = address Indexable.either\n\n val encoding : either Data_encoding.t\n\n val index_encoding : index Data_encoding.t\n\n val compare_values : value -> value -> int\n\n val value_encoding : value Data_encoding.t\n\n val compare : 'state t -> 'state' t -> int\n\n val value : address -> value\n\n val index : int32 -> index tzresult\n\n val index_exn : int32 -> index\n\n val pp : Format.formatter -> 'state t -> unit\n\n val size : 'state t -> int\n\n val in_memory_size : 'state t -> Cache_memory_helpers.sint\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ninclude Bls.Public_key_hash\n\ntype address = t\n\nlet in_memory_size : t -> Cache_memory_helpers.sint =\n fun _ ->\n let open Cache_memory_helpers in\n header_size +! word_size +! string_size_gen Bls.Public_key_hash.size\n\nlet size _ = Bls.Public_key_hash.size\n\nmodule Indexable = struct\n include Indexable.Make (struct\n type nonrec t = t\n\n let encoding = encoding\n\n let compare = compare\n\n let pp = pp\n end)\n\n let in_memory_size x = Indexable.in_memory_size in_memory_size x\n\n let size x = Indexable.size size x\nend\n" ;
} ;
{ name = "Tx_rollup_l2_qty" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module is an abstraction on top of int64 to build positive (or zero)\n quantities within the int64 bounds. It comes with a compact encoding to be\n used in the transaction rollup batches. *)\n\n(** Type of postive quantities. Quantities are bounded by {!Int64.max_int}. *)\ntype t\n\n(** The zero quantity. *)\nval zero : t\n\n(** One quantity. *)\nval one : t\n\n(** Build a quantity from an int64. Returns [None] if the argument is negative. *)\nval of_int64 : int64 -> t option\n\n(** Build a quantity from an int64 and raise [Invalid_argument] on negative quantities. *)\nval of_int64_exn : int64 -> t\n\n(** Convert a quantity to [int64]. *)\nval to_int64 : t -> int64\n\n(** Convert a quantity to [z]. *)\nval to_z : t -> Z.t\n\n(** Returns a string representation of a quantity. *)\nval to_string : t -> string\n\n(** Parse a quantity from a string. Returns [None] if the string is not a valid\n quantity representation. *)\nval of_string : string -> t option\n\n(** Pretty-printer for quantities. *)\nval pp : Format.formatter -> t -> unit\n\n(** Compact encoding for quantities *)\nval compact_encoding : t Data_encoding.Compact.t\n\n(** Encoding for quantities *)\nval encoding : t Data_encoding.t\n\n(** Substract two quantities. Returns [None] on subtraction underflow. *)\nval sub : t -> t -> t option\n\n(** Add two quantities. Returns [None] on addition overflow. *)\nval add : t -> t -> t option\n\n(** Return the [t] successor. Returns [None] on overflow. *)\nval succ : t -> t option\n\n(** Quantities substraction. *)\nval ( - ) : t -> t -> t option\n\n(** Quantities addition. *)\nval ( + ) : t -> t -> t option\n\ninclude Compare.S with type t := t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ninclude Compare.Int64\n\nlet zero = 0L\n\nlet one = 1L\n\nlet of_int64 q = if q < 0L then None else Some q\n\nlet of_int64_exn q =\n match of_int64 q with\n | Some q -> q\n | None -> invalid_arg \"Tx_rollup_l2_qty.of_int64_exn\"\n\nlet to_int64 q = q\n\nlet to_z = Z.of_int64\n\nlet to_string q = Int64.to_string q\n\nlet of_string q = Option.bind (Int64.of_string_opt q) of_int64\n\nlet pp fmt q = Format.pp_print_string fmt (to_string q)\n\nlet compact_encoding = Data_encoding.Compact.(conv to_int64 of_int64_exn int64)\n\nlet encoding = Data_encoding.Compact.(make ~tag_size:`Uint8 compact_encoding)\n\nlet sub q1 q2 = if q2 <= q1 then Some (Int64.sub q1 q2) else None\n\nlet add q1 q2 =\n let q = Int64.add q1 q2 in\n if q < q1 then None else Some q\n\nlet succ q = add q one\n\nlet ( - ) = sub\n\nlet ( + ) = add\n" ;
} ;
{ name = "Tx_rollup_l2_context_hash" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** A specialized Blake2B implementation for hashing tx_rollup contexts. *)\n\ninclude S.HASH\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ninclude\n Blake2B.Make\n (Base58)\n (struct\n let name = \"tx_rollup_context_hash\"\n\n let title = \"Hash of a transaction rollup context\"\n\n let b58check_prefix = \"\\017\\143\\019\" (* CTx(53) *)\n\n let size = Some 32\n end)\n\nlet () = Base58.check_encoded_prefix b58check_encoding \"CTx\" 53\n" ;
} ;
{ name = "Tx_rollup_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module defines identifiers for transaction only rollup (or\n tx rollup). It also specifies how to compute originated\n tx rollup's hash from origination nonce. *)\n\n(** A specialized Blake2B implementation for hashing tx_rollup identifiers with\n \"txr1\" as a base58 prefix *)\nmodule Hash : sig\n val rollup_hash : string\n\n include S.HASH\nend\n\ntype t = private Hash.t\n\ninclude Compare.S with type t := t\n\n(** [in_memory_size tx_rollup] returns the number of bytes [tx_rollup]\n uses in RAM. *)\nval in_memory_size : t -> Cache_memory_helpers.sint\n\nval to_b58check : t -> string\n\nval of_b58data : Base58.data -> t option\n\nval of_b58check : string -> t tzresult\n\nval of_b58check_opt : string -> t option\n\nval pp : Format.formatter -> t -> unit\n\nval encoding : t Data_encoding.t\n\n(** [originated_tx_rollup nonce] is the tx_rollup address originated from\n [nonce]. See [Origination_nonce.t] for more information. *)\nval originated_tx_rollup : Origination_nonce.t -> t\n\nval rpc_arg : t RPC_arg.arg\n\nmodule Index : Storage_description.INDEX with type t = t\n\nmodule Set : Set.S with type elt = t\n\nmodule Map : Map.S with type key = t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021-2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error += (* `Permanent *) Invalid_rollup_notation of string\n\nlet () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"rollup.invalid_tx_rollup_notation\"\n ~title:\"Invalid tx rollup notation\"\n ~pp:(fun ppf x -> Format.fprintf ppf \"Invalid tx rollup notation %S\" x)\n ~description:\n \"A malformed tx rollup notation was given to an RPC or in a script.\"\n (obj1 (req \"notation\" (string Plain)))\n (function Invalid_rollup_notation loc -> Some loc | _ -> None)\n (fun loc -> Invalid_rollup_notation loc)\n\nmodule Hash = struct\n let rollup_hash = Tx_rollup_prefixes.rollup_address.b58check_prefix\n\n module H =\n Blake2B.Make\n (Base58)\n (struct\n let name = \"Rollup_hash\"\n\n let title = \"A rollup ID\"\n\n let b58check_prefix = rollup_hash\n\n let size = Some Tx_rollup_prefixes.rollup_address.hash_size\n end)\n\n include H\n\n let () = Tx_rollup_prefixes.(check_encoding rollup_address b58check_encoding)\n\n include Path_encoding.Make_hex (H)\nend\n\ntype t = Hash.t\n\nmodule Compare_impl = Compare.Make (struct\n type nonrec t = t\n\n let compare r1 r2 = Hash.compare r1 r2\nend)\n\ninclude Compare_impl\n\nlet in_memory_size _ =\n let open Cache_memory_helpers in\n header_size +! word_size\n +! string_size_gen Tx_rollup_prefixes.rollup_address.hash_size\n\nlet to_b58check rollup = Hash.to_b58check rollup\n\nlet of_b58data = function Hash.Data hash -> Some hash | _ -> None\n\nlet of_b58check_opt s = Option.bind (Base58.decode s) of_b58data\n\nlet of_b58check s =\n match of_b58check_opt s with\n | Some hash -> ok hash\n | _ -> error (Invalid_rollup_notation s)\n\nlet pp ppf hash = Hash.pp ppf hash\n\nlet encoding =\n let open Data_encoding in\n def\n \"tx_rollup_id\"\n ~title:\"A tx rollup handle\"\n ~description:\n \"A tx rollup notation as given to an RPC or inside scripts, is a base58 \\\n tx rollup hash\"\n @@ splitted\n ~binary:Hash.encoding\n ~json:\n (conv\n to_b58check\n (fun s ->\n match of_b58check s with\n | Ok s -> s\n | Error _ -> Json.cannot_destruct \"Invalid tx rollup notation.\")\n (string Plain))\n\nlet originated_tx_rollup nonce =\n let data =\n Data_encoding.Binary.to_bytes_exn Origination_nonce.encoding nonce\n in\n Hash.hash_bytes [data]\n\nlet rpc_arg =\n let construct = to_b58check in\n let destruct hash =\n Result.map_error (fun _ -> \"Cannot parse tx rollup id\") (of_b58check hash)\n in\n RPC_arg.make\n ~descr:\"A tx rollup identifier encoded in b58check.\"\n ~name:\"tx_rollup_id\"\n ~construct\n ~destruct\n ()\n\nmodule Index = struct\n type nonrec t = t\n\n let path_length = 1\n\n let to_path c l =\n let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in\n let (`Hex key) = Hex.of_bytes raw_key in\n key :: l\n\n let of_path = function\n | [key] ->\n Option.bind\n (Hex.to_bytes (`Hex key))\n (Data_encoding.Binary.of_bytes_opt encoding)\n | _ -> None\n\n let rpc_arg = rpc_arg\n\n let encoding = encoding\n\n let compare = compare\nend\n\nmodule Cmp = struct\n type nonrec t = t\n\n let compare = compare\nend\n\nmodule Set = Set.Make (Cmp)\nmodule Map = Map.Make (Cmp)\n" ;
} ;
{ name = "Tx_rollup_withdraw_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxheadalpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** A withdraw order gives right to a L1 address [claimer] to retrieve\n the quantity [amount] of a ticket whose hash is [ticket_hash].\n Withdrawals result from layer-2-to-layer-1 transfers, and from\n failed layer-2 deposits.*)\ntype order = {\n claimer : Signature.Public_key_hash.t;\n ticket_hash : Ticket_hash_repr.t;\n amount : Tx_rollup_l2_qty.t;\n}\n\ntype t = order\n\nval encoding : t Data_encoding.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxheadalpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype order = {\n claimer : Signature.Public_key_hash.t;\n ticket_hash : Ticket_hash_repr.t;\n amount : Tx_rollup_l2_qty.t;\n}\n\ntype t = order\n\nlet encoding : t Data_encoding.t =\n let open Data_encoding in\n conv\n (fun {claimer; ticket_hash; amount} -> (claimer, ticket_hash, amount))\n (fun (claimer, ticket_hash, amount) -> {claimer; ticket_hash; amount})\n (obj3\n (req \"claimer\" Signature.Public_key_hash.encoding)\n (req \"ticket_hash\" Ticket_hash_repr.encoding)\n (req \"amount\" Tx_rollup_l2_qty.encoding))\n" ;
} ;
{ name = "Tx_rollup_withdraw_list_hash_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ninclude S.HASH\n\nval hash_uncarbonated : Tx_rollup_withdraw_repr.t list -> t\n\nval empty : t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nlet prefix = Tx_rollup_prefixes.withdraw_list_hash.b58check_prefix\n\nmodule H =\n Blake2B.Make\n (Base58)\n (struct\n let name = \"Withdraw_list_hash\"\n\n let title = \"A list of withdraw orders\"\n\n let b58check_prefix = prefix\n\n let size = Some Tx_rollup_prefixes.withdraw_list_hash.hash_size\n end)\n\ninclude H\ninclude Path_encoding.Make_hex (H)\n\nlet () =\n Tx_rollup_prefixes.(check_encoding withdraw_list_hash b58check_encoding)\n\nlet hash_uncarbonated l =\n let bytes =\n Data_encoding.(\n Binary.to_bytes_exn (list Tx_rollup_withdraw_repr.encoding) l)\n in\n H.hash_bytes [bytes]\n\nlet empty = hash_uncarbonated []\n" ;
} ;
{ name = "Tx_rollup_reveal_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** A reveal provides what is necessary to recompute a\n {!Tx_rollup_withdrawal.t} message. *)\ntype t = {\n contents : Script_repr.lazy_expr;\n ty : Script_repr.lazy_expr;\n ticketer : Contract_repr.t;\n amount : Tx_rollup_l2_qty.t;\n claimer : Signature.Public_key_hash.t;\n}\n\nval encoding : t Data_encoding.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t = {\n contents : Script_repr.lazy_expr;\n ty : Script_repr.lazy_expr;\n ticketer : Contract_repr.t;\n amount : Tx_rollup_l2_qty.t;\n claimer : Signature.Public_key_hash.t;\n}\n\nlet encoding : t Data_encoding.t =\n let open Data_encoding in\n conv\n (fun {contents; ty; ticketer; amount; claimer} ->\n (contents, ty, ticketer, amount, claimer))\n (fun (contents, ty, ticketer, amount, claimer) ->\n {contents; ty; ticketer; amount; claimer})\n (obj5\n (req \"contents\" Script_repr.lazy_expr_encoding)\n (req \"ty\" Script_repr.lazy_expr_encoding)\n (req \"ticketer\" Contract_repr.encoding)\n (req \"amount\" Tx_rollup_l2_qty.encoding)\n (req \"claimer\" Signature.Public_key_hash.encoding))\n" ;
} ;
{ name = "Tx_rollup_message_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Communication from the layer-1 (Tezos) to the layer-2 (a\n transaction rollup) happens thanks to messages, crafted in the\n layer-1 to be interpreted in the layer-2.\n\n Messages are constructed and gathered in the layer-1, in\n inboxes (see {!Tx_rollup_repr_storage.append_message}). *)\n\n(** Smart contract on the layer-1 can deposit tickets into a\n transaction rollup, for the benefit of a {!Tx_rollup_l2_address.t}.\n The [sender] is an implicit account where the deposit is returned in form of\n a withdrawal, should the application of the deposit fail.\n *)\ntype deposit = {\n sender : Signature.Public_key_hash.t;\n destination : Tx_rollup_l2_address.Indexable.value;\n ticket_hash : Ticket_hash_repr.t;\n amount : Tx_rollup_l2_qty.t;\n}\n\n(** A [message] is a piece of data originated from the layer-1 to be\n interpreted by the layer-2.\n\n Transaction rollups feature two kind of messages:\n\n {ul {li An array of bytes that supposedly contains a valid\n sequence of layer-2 operations; their interpretation and\n validation is deferred to the layer-2..}\n {li A deposit order for a L1 ticket.}} *)\ntype t = Batch of string | Deposit of deposit\n\n(** [size msg] returns the number of bytes that are allocated in an\n inbox by [msg]. *)\nval size : t -> int\n\nval deposit_encoding : deposit Data_encoding.t\n\nval encoding : t Data_encoding.t\n\nval pp : Format.formatter -> t -> unit\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype deposit = {\n sender : Signature.Public_key_hash.t;\n destination : Tx_rollup_l2_address.Indexable.value;\n ticket_hash : Ticket_hash_repr.t;\n amount : Tx_rollup_l2_qty.t;\n}\n\nlet deposit_encoding =\n let open Data_encoding in\n conv\n (fun {sender; destination; ticket_hash; amount} ->\n (sender, destination, ticket_hash, amount))\n (fun (sender, destination, ticket_hash, amount) ->\n {sender; destination; ticket_hash; amount})\n @@ obj4\n (req \"sender\" Signature.Public_key_hash.encoding)\n (req \"destination\" Tx_rollup_l2_address.Indexable.value_encoding)\n (req \"ticket_hash\" Ticket_hash_repr.encoding)\n (req \"amount\" Tx_rollup_l2_qty.encoding)\n\ntype t = Batch of string | Deposit of deposit\n\nlet encoding =\n let open Data_encoding in\n union\n ~tag_size:`Uint8\n [\n case\n (Tag 0)\n ~title:\"Batch\"\n (obj1 (req \"batch\" (string Hex)))\n (function Batch batch -> Some batch | _ -> None)\n (fun batch -> Batch batch);\n case\n (Tag 1)\n ~title:\"Deposit\"\n (obj1 (req \"deposit\" deposit_encoding))\n (function Deposit deposit -> Some deposit | _ -> None)\n (fun deposit -> Deposit deposit);\n ]\n\nlet pp fmt =\n let open Format in\n function\n | Batch str ->\n let subsize = 10 in\n let str, ellipsis =\n if Compare.Int.(subsize < String.length str) then\n let substring = String.sub str 0 subsize in\n (substring, \"...\")\n else (str, \"\")\n in\n fprintf\n fmt\n \"@[<hov 2>Batch:@ %s%s@]\"\n (Hex.of_string str |> Hex.show)\n ellipsis\n | Deposit {sender; destination; ticket_hash; amount} ->\n fprintf\n fmt\n \"@[<hov 2>Deposit:@ sender=%a,@ destination=%a,@ ticket_hash=%a,@ \\\n amount:%a@]\"\n Signature.Public_key_hash.pp\n sender\n Tx_rollup_l2_address.Indexable.pp\n destination\n Ticket_hash_repr.pp\n ticket_hash\n Tx_rollup_l2_qty.pp\n amount\n\nlet size = function\n | Batch batch -> String.length batch\n | Deposit {sender = _; destination = d; ticket_hash = _; amount = _} ->\n (* Size of a BLS public key, that is the underlying type of a\n l2 address. See [Tx_rollup_l2_address] *)\n let sender_size = Signature.Public_key_hash.size in\n (* Size of a BLS public key, that is the underlying type of a\n l2 address. See [Tx_rollup_l2_address] *)\n let destination_size = Tx_rollup_l2_address.Indexable.size d in\n (* Size of a [Script_expr_hash.t], that is the underlying type\n of [Ticket_hash_repr.t]. *)\n let key_hash_size = 32 in\n (* [int64] *)\n let amount_size = 8 in\n sender_size + destination_size + key_hash_size + amount_size\n" ;
} ;
{ name = "Tx_rollup_message_hash_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxheadalpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** The Blake2B hash of a message.\n\n To avoid unnecessary storage duplication, the inboxes in the\n layer-1 do not contain the messages, but their hashes (see\n {!Tx_rollup_inbox_storage.append_message}). This is possible\n because the content of the messages can be reconstructed off-chain\n by looking at the layer-1 operations and their receipt. *)\n\ninclude S.HASH\n\n(** [hash_uncarbonated msg] computes the hash of the given message\n without any gas consumption. *)\nval hash_uncarbonated : Tx_rollup_message_repr.t -> t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nlet hash_size = Tx_rollup_prefixes.message_hash.hash_size\n\nmodule Message_hash =\n Blake2B.Make\n (Base58)\n (struct\n let name = \"Tx_rollup_inbox_message_hash\"\n\n let title = \"The hash of a transaction rollup inbox\226\128\153s message\"\n\n let b58check_prefix = Tx_rollup_prefixes.message_hash.b58check_prefix\n\n let size = Some hash_size\n end)\n\nlet () =\n Tx_rollup_prefixes.(\n check_encoding message_hash Message_hash.b58check_encoding)\n\ninclude Message_hash\n\nlet hash_uncarbonated msg =\n Message_hash.hash_bytes\n [Data_encoding.Binary.to_bytes_exn Tx_rollup_message_repr.encoding msg]\n" ;
} ;
{ name = "Tx_rollup_inbox_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule Merkle : sig\n (** See {!Merkle_List} for the documentation of those functions. *)\n\n type tree\n\n type root\n\n type path\n\n val empty : tree\n\n val root : tree -> root\n\n val ( = ) : root -> root -> bool\n\n val compare : root -> root -> int\n\n val root_encoding : root Data_encoding.t\n\n val root_of_b58check_opt : string -> root option\n\n val pp_root : Format.formatter -> root -> unit\n\n val path_encoding : path Data_encoding.t\n\n val add_message : tree -> Tx_rollup_message_hash_repr.t -> tree\n\n val compute_path : Tx_rollup_message_hash_repr.t list -> int -> path tzresult\n\n val check_path :\n path -> int -> Tx_rollup_message_hash_repr.t -> root -> bool tzresult\n\n val path_depth : path -> int\n\n (** [merklize_list messages] construct a merkle root by build a\n tree, appending the [messages] one by one in the same order of\n the list and finally computing the root. *)\n val merklize_list : Tx_rollup_message_hash_repr.t list -> root\nend\n\n(** The view of an inbox: stores the [cumulated_size] in bytes for the\n inbox, the [inbox_length] ({i i.e.}, the number of messages), and\n the cumulative [hash] of the inbox contents. For newly created\n inboxes, the [hash] is initialized as an array 32 null\n byte. *)\ntype t = {inbox_length : int; cumulated_size : int; merkle_root : Merkle.root}\n\n(** [size] is the number of bytes necessary to store an inbox in the\n layer-1 storage. *)\nval size : Z.t\n\nval ( = ) : t -> t -> bool\n\nval encoding : t Data_encoding.t\n\nval empty : t\n\nval pp : Format.formatter -> t -> unit\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule El = struct\n type t = Tx_rollup_message_hash_repr.t\n\n let to_bytes =\n Data_encoding.Binary.to_bytes_exn Tx_rollup_message_hash_repr.encoding\nend\n\nmodule Prefix = struct\n let name = \"Inbox_list_hash\"\n\n let title = \"A merkle root hash for inboxes\"\n\n let b58check_prefix = Tx_rollup_prefixes.inbox_list_hash.b58check_prefix\n\n let size = Some Tx_rollup_prefixes.inbox_list_hash.hash_size\nend\n\nmodule H = Blake2B.Make (Base58) (Prefix)\nmodule Merkle_list = Merkle_list.Make (El) (H)\n\nmodule Merkle = struct\n type tree = Merkle_list.t\n\n type root = Merkle_list.h\n\n type path = Merkle_list.path\n\n let empty = Merkle_list.nil\n\n let root = Merkle_list.root\n\n let ( = ) = H.( = )\n\n let compare = H.compare\n\n let root_encoding = H.encoding\n\n let root_of_b58check_opt = H.of_b58check_opt\n\n let pp_root = H.pp\n\n let path_encoding = Merkle_list.path_encoding\n\n let add_message = Merkle_list.snoc\n\n let tree_of_messages = List.fold_left Merkle_list.snoc Merkle_list.nil\n\n let compute_path messages position =\n let tree = tree_of_messages messages in\n Merkle_list.compute_path tree position\n\n let check_path = Merkle_list.check_path\n\n let path_depth = Merkle_list.path_depth\n\n let merklize_list messages =\n let tree = tree_of_messages messages in\n root tree\nend\n\ntype t = {inbox_length : int; cumulated_size : int; merkle_root : Merkle.root}\n\nlet ( = )\n {\n inbox_length = inbox_length_left;\n cumulated_size = cumulated_size_left;\n merkle_root = merkle_root_left;\n }\n {\n inbox_length = inbox_length_right;\n cumulated_size = cumulated_size_right;\n merkle_root = merkle_root_right;\n } =\n Compare.Int.(inbox_length_left = inbox_length_right)\n && Compare.Int.(cumulated_size_left = cumulated_size_right)\n && Merkle.(merkle_root_left = merkle_root_right)\n\nlet encoding =\n let open Data_encoding in\n conv\n (fun {inbox_length; cumulated_size; merkle_root} ->\n (inbox_length, cumulated_size, merkle_root))\n (fun (inbox_length, cumulated_size, merkle_root) ->\n {inbox_length; cumulated_size; merkle_root})\n (obj3\n (req \"inbox_length\" int31)\n (req \"cumulated_size\" int31)\n (req \"merkle_root\" Merkle.root_encoding))\n\nlet empty =\n {inbox_length = 0; cumulated_size = 0; merkle_root = Merkle_list.empty}\n\nlet size = Z.of_int @@ Data_encoding.Binary.length encoding empty\n\nlet pp fmt {inbox_length; cumulated_size; merkle_root} =\n Format.fprintf\n fmt\n \"Inbox with length %d, size %d, merkle root %a\"\n inbox_length\n cumulated_size\n Merkle.pp_root\n merkle_root\n" ;
} ;
{ name = "Tx_rollup_message_result_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t = {\n context_hash : Context_hash.t;\n withdraw_list_hash : Tx_rollup_withdraw_list_hash_repr.t;\n}\n\nval encoding : t Data_encoding.t\n\nval init : t\n\n(** [empty_l2_context_hash] is the context hash of the layer-2 context\n just after its origination.\n\n The empty layer2 context hash is the hash of the underlying Irmin tree.\n One important note is: an empty tree *must* not be hashed when it's empty.\n See https://github.com/mirage/irmin/issues/1304.\n\n Our solution is to write data in the tree to have a non-empty one.\n We write the {!Tx_rollup_l2_context.Ticket_count} default value (i.e. 0)\n and the {!Tx_rollup_l2_context.Address_count} as well in the tree. Then\n we hash the resulting tree to create this constant.\n*)\nval empty_l2_context_hash : Context_hash.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxheadalpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t = {\n context_hash : Context_hash.t;\n withdraw_list_hash : Tx_rollup_withdraw_list_hash_repr.t;\n}\n\nlet encoding =\n let open Data_encoding in\n conv\n (fun {context_hash; withdraw_list_hash} ->\n (context_hash, withdraw_list_hash))\n (fun (context_hash, withdraw_list_hash) ->\n {context_hash; withdraw_list_hash})\n (obj2\n (req \"context_hash\" Context_hash.encoding)\n (req \"withdraw_list_hash\" Tx_rollup_withdraw_list_hash_repr.encoding))\n\nlet empty_l2_context_hash =\n Context_hash.of_b58check_exn\n \"CoVu7Pqp1Gh3z33mink5T5Q2kAQKtnn3GHxVhyehdKZpQMBxFBGF\"\n\nlet init =\n {\n context_hash = empty_l2_context_hash;\n withdraw_list_hash = Tx_rollup_withdraw_list_hash_repr.empty;\n }\n" ;
} ;
{ name = "Tx_rollup_message_result_hash_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxheadalpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** The hash of the result of a layer-2 operation: that is, the hash\n of [(l2_ctxt_hash ^ withdraw_hash)] where [l2_ctxt_hash] is the Merkle\n tree root of the L2 context after any message (ie. deposit or batch),\n and [withdraw_hash] is a [Tx_rollup_withdraw_repr.withdraw_list_hash] *)\n\ninclude S.HASH\n\n(** [hash_uncarbonated result] computes the hash of the given context\n hash and withdraw list hash without any gas consumption. *)\nval hash_uncarbonated : Tx_rollup_message_result_repr.t -> t\n\nval init : t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxheadalpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nlet message_result_hash = Tx_rollup_prefixes.message_result_hash.b58check_prefix\n\nmodule H =\n Blake2B.Make\n (Base58)\n (struct\n let name = \"Message_result_hash\"\n\n let title = \"A message result hash\"\n\n let b58check_prefix = message_result_hash\n\n let size = Some Tx_rollup_prefixes.message_result_hash.hash_size\n end)\n\ninclude H\ninclude Path_encoding.Make_hex (H)\n\nlet () =\n Tx_rollup_prefixes.(check_encoding message_result_hash b58check_encoding)\n\nlet hash_uncarbonated result =\n let bytes =\n Data_encoding.Binary.to_bytes_exn\n Tx_rollup_message_result_repr.encoding\n result\n in\n H.hash_bytes [bytes]\n\nlet init = hash_uncarbonated Tx_rollup_message_result_repr.init\n" ;
} ;
{ name = "Tx_rollup_commitment_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxheadalpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** A specialized Blake2B implementation for hashing commitments with\n \"toc1\" as a base58 prefix *)\nmodule Hash : sig\n val commitment_hash : string\n\n include S.HASH\nend\n\nmodule Merkle_hash : S.HASH\n\nmodule Merkle :\n Merkle_list.T\n with type elt = Tx_rollup_message_result_hash_repr.t\n and type h = Merkle_hash.t\n\n(** A commitment describes the interpretation of the messages stored in the\n inbox of a particular [level], on top of a particular layer-2 context.\n\n It includes one Merkle tree root for each of the [batches]. It has\n a [predecessor], which is the identifier of the commitment for the\n previous inbox. The [predecessor] is used to get the Merkle root\n of the layer-2 context before any inboxes are processed. If\n [predecessor] is [None], the commitment is for the first inbox\n with messages in this rollup, and the initial Merkle root is the\n empty tree. *)\ntype 'a template = {\n level : Tx_rollup_level_repr.t;\n messages : 'a;\n predecessor : Hash.t option;\n inbox_merkle_root : Tx_rollup_inbox_repr.Merkle.root;\n}\n\nmodule Compact : sig\n type excerpt = {\n count : int;\n root : Merkle.h;\n last_result_message_hash : Tx_rollup_message_result_hash_repr.t;\n }\n\n type t = excerpt template\n\n val pp : Format.formatter -> t -> unit\n\n val encoding : t Data_encoding.t\n\n val hash : t -> Hash.t\nend\n\nmodule Full : sig\n type t = Tx_rollup_message_result_hash_repr.t list template\n\n val encoding : t Data_encoding.t\n\n val pp : Format.formatter -> t -> unit\n\n val compact : t -> Compact.t\nend\n\nmodule Index : Storage_description.INDEX with type t = Hash.t\n\nmodule Submitted_commitment : sig\n (** When a commitment is submitted, we store the [committer] and the\n block the commitment was [submitted_at] along with the\n [commitment] itself with its hash. *)\n type nonrec t = {\n commitment : Compact.t;\n commitment_hash : Hash.t;\n committer : Signature.Public_key_hash.t;\n submitted_at : Raw_level_repr.t;\n finalized_at : Raw_level_repr.t option;\n }\n\n val encoding : t Data_encoding.t\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxheadalpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule Hash = struct\n let commitment_hash = Tx_rollup_prefixes.commitment_hash.b58check_prefix\n\n module H =\n Blake2B.Make\n (Base58)\n (struct\n let name = \"Commitment_hash\"\n\n let title = \"A commitment ID\"\n\n let b58check_prefix = commitment_hash\n\n let size = Some Tx_rollup_prefixes.commitment_hash.hash_size\n end)\n\n include H\n\n let () = Tx_rollup_prefixes.(check_encoding commitment_hash b58check_encoding)\n\n include Path_encoding.Make_hex (H)\n\n let rpc_arg =\n let construct = Data_encoding.Binary.to_string_exn encoding in\n let destruct str =\n Option.value_e ~error:\"Failed to decode commitment\"\n @@ Data_encoding.Binary.of_string_opt encoding str\n in\n RPC_arg.make\n ~descr:\"A tx_rollup commitment.\"\n ~name:\"tx_rollup_commitment\"\n ~construct\n ~destruct\n ()\nend\n\nmodule Merkle_hash = struct\n module H =\n Blake2B.Make\n (Base58)\n (struct\n let name = \"Message_result_list_hash\"\n\n let title = \"A merklised message result list hash\"\n\n let b58check_prefix =\n Tx_rollup_prefixes.message_result_list_hash.b58check_prefix\n\n let size = Some Tx_rollup_prefixes.message_result_list_hash.hash_size\n end)\n\n include H\n include Path_encoding.Make_hex (H)\n\n let () =\n Tx_rollup_prefixes.(\n check_encoding message_result_list_hash b58check_encoding)\nend\n\nmodule Merkle =\n Merkle_list.Make (Tx_rollup_message_result_hash_repr) (Merkle_hash)\n\ntype 'a template = {\n level : Tx_rollup_level_repr.t;\n messages : 'a;\n predecessor : Hash.t option;\n inbox_merkle_root : Tx_rollup_inbox_repr.Merkle.root;\n}\n\nlet map_template f x = {x with messages = f x.messages}\n\nlet pp_template :\n (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a template -> unit\n =\n fun pp_messages fmt t ->\n Format.fprintf\n fmt\n \"Level: %a@,Messages: %a@,Predecessor: %a@,Inbox merkle root: %a\"\n Tx_rollup_level_repr.pp\n t.level\n pp_messages\n t.messages\n (Format.pp_print_option\n ~none:(fun fmt () -> Format.pp_print_string fmt \"None\")\n Hash.pp)\n t.predecessor\n Tx_rollup_inbox_repr.Merkle.pp_root\n t.inbox_merkle_root\n\nlet encoding_template encoding =\n let open Data_encoding in\n conv\n (fun {level; messages; predecessor; inbox_merkle_root} ->\n (level, messages, predecessor, inbox_merkle_root))\n (fun (level, messages, predecessor, inbox_merkle_root) ->\n {level; messages; predecessor; inbox_merkle_root})\n (obj4\n (req \"level\" Tx_rollup_level_repr.encoding)\n (req \"messages\" encoding)\n (req \"predecessor\" (option Hash.encoding))\n (req \"inbox_merkle_root\" Tx_rollup_inbox_repr.Merkle.root_encoding))\n\nmodule Compact = struct\n type excerpt = {\n count : int;\n root : Merkle.h;\n last_result_message_hash : Tx_rollup_message_result_hash_repr.t;\n }\n\n type t = excerpt template\n\n let pp =\n pp_template (fun fmt {count; root; last_result_message_hash} ->\n Format.fprintf\n fmt\n \"Count: %d@, Merkle root hash: %a@,Last result message hash: %a\"\n count\n Merkle_hash.pp\n root\n Tx_rollup_message_result_hash_repr.pp\n last_result_message_hash)\n\n let encoding =\n encoding_template\n Data_encoding.(\n conv\n (fun {count; root; last_result_message_hash} ->\n (count, root, last_result_message_hash))\n (fun (count, root, last_result_message_hash) ->\n {count; root; last_result_message_hash})\n @@ obj3\n (req \"count\" int31)\n (req \"root\" Merkle_hash.encoding)\n (req\n \"last_message_result_hash\"\n Tx_rollup_message_result_hash_repr.encoding))\n\n let hash t =\n let bytes = Data_encoding.Binary.to_bytes_exn encoding t in\n Hash.hash_bytes [bytes]\nend\n\nmodule Full = struct\n type t = Tx_rollup_message_result_hash_repr.t list template\n\n let pp =\n pp_template (Format.pp_print_list Tx_rollup_message_result_hash_repr.pp)\n\n let encoding : t Data_encoding.t =\n encoding_template\n (Data_encoding.list Tx_rollup_message_result_hash_repr.encoding)\n\n let compact full =\n map_template\n (fun list ->\n let root = Merkle.compute list in\n List.fold_left\n (fun (acc, _) m -> (acc + 1, m))\n (0, Tx_rollup_message_result_hash_repr.zero)\n list\n |> fun (count, last_result_message_hash) ->\n Compact.{count; root; last_result_message_hash})\n full\nend\n\nmodule Index = struct\n type t = Hash.t\n\n let path_length = 1\n\n let to_path c l =\n let raw_key = Data_encoding.Binary.to_bytes_exn Hash.encoding c in\n let (`Hex key) = Hex.of_bytes raw_key in\n key :: l\n\n let of_path = function\n | [key] ->\n Option.bind\n (Hex.to_bytes (`Hex key))\n (Data_encoding.Binary.of_bytes_opt Hash.encoding)\n | _ -> None\n\n let rpc_arg = Hash.rpc_arg\n\n let encoding = Hash.encoding\n\n let compare = Hash.compare\nend\n\nmodule Submitted_commitment = struct\n type nonrec t = {\n commitment : Compact.t;\n commitment_hash : Hash.t;\n committer : Signature.Public_key_hash.t;\n submitted_at : Raw_level_repr.t;\n finalized_at : Raw_level_repr.t option;\n }\n\n let encoding =\n let compact = Compact.encoding in\n let open Data_encoding in\n conv\n (fun {commitment; commitment_hash; committer; submitted_at; finalized_at} ->\n (commitment, commitment_hash, committer, submitted_at, finalized_at))\n (fun (commitment, commitment_hash, committer, submitted_at, finalized_at) ->\n {commitment; commitment_hash; committer; submitted_at; finalized_at})\n (obj5\n (req \"commitment\" compact)\n (req \"commitment_hash\" Hash.encoding)\n (req \"committer\" Signature.Public_key_hash.encoding)\n (req \"submitted_at\" Raw_level_repr.encoding)\n (opt \"finalized_at\" Raw_level_repr.encoding))\nend\n" ;
} ;
{ name = "Tx_rollup_errors_repr" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error +=\n | Tx_rollup_already_exists of Tx_rollup_repr.t\n | Tx_rollup_does_not_exist of Tx_rollup_repr.t\n | Submit_batch_burn_exceeded of {burn : Tez_repr.t; limit : Tez_repr.t}\n | Inbox_does_not_exist of Tx_rollup_repr.t * Tx_rollup_level_repr.t\n | Inbox_size_would_exceed_limit of Tx_rollup_repr.t\n | Inbox_count_would_exceed_limit of Tx_rollup_repr.t\n | No_uncommitted_inbox\n | Message_size_exceeds_limit\n | Too_many_inboxes\n | Too_many_commitments\n | Too_many_withdrawals\n | Wrong_batch_count\n | Commitment_too_early of {\n provided : Tx_rollup_level_repr.t;\n expected : Tx_rollup_level_repr.t;\n }\n | Level_already_has_commitment of Tx_rollup_level_repr.t\n | Wrong_inbox_hash\n | Bond_does_not_exist of Signature.public_key_hash\n | Bond_in_use of Signature.public_key_hash\n | No_commitment_to_finalize\n | No_commitment_to_remove\n | Remove_commitment_too_early\n | Commitment_does_not_exist of Tx_rollup_level_repr.t\n | Wrong_predecessor_hash of {\n provided : Tx_rollup_commitment_repr.Hash.t option;\n expected : Tx_rollup_commitment_repr.Hash.t option;\n }\n | Internal_error of string\n | Wrong_message_position of {\n level : Tx_rollup_level_repr.t;\n position : int;\n length : int;\n }\n | Wrong_path_depth of {\n kind : [`Inbox | `Commitment];\n provided : int;\n limit : int;\n }\n | Wrong_message_path of {expected : Tx_rollup_inbox_repr.Merkle.root}\n | No_finalized_commitment_for_level of {\n level : Tx_rollup_level_repr.t;\n window : (Tx_rollup_level_repr.t * Tx_rollup_level_repr.t) option;\n }\n | Withdraw_invalid_path\n | Withdraw_already_consumed\n | Withdrawals_invalid_path\n | Withdrawals_already_dispatched\n | Invalid_committer\n | Commitment_bond_negative of int\n | Cannot_reject_level of {\n provided : Tx_rollup_level_repr.t;\n accepted_range : (Tx_rollup_level_repr.t * Tx_rollup_level_repr.t) option;\n }\n | Wrong_rejection_hash of {\n provided : Tx_rollup_message_result_hash_repr.t;\n expected :\n [ `Valid_path of Tx_rollup_commitment_repr.Merkle.h * int\n | `Hash of Tx_rollup_message_result_hash_repr.t ];\n }\n | Ticket_payload_size_limit_exceeded of {\n payload_size : Saturation_repr.may_saturate Saturation_repr.t;\n limit : int;\n }\n | Proof_undecodable\n | Proof_failed_to_reject\n | Proof_produced_rejected_state\n | Proof_invalid_before of {agreed : Context_hash.t; provided : Context_hash.t}\n | No_withdrawals_to_dispatch\n\nlet check_path_depth kind provided ~count_limit =\n let limit = Merkle_list.max_depth ~count_limit in\n error_when Compare.Int.(limit < provided)\n @@ Wrong_path_depth {kind; provided; limit}\n\nlet () =\n let open Data_encoding in\n (* Tx_rollup_submit_batch_burn_exceeded *)\n register_error_kind\n `Temporary\n ~id:\"operation.tx_rollup_submit_batch_burn_exceeded\"\n ~title:\"Submit batch exceeded burn limit\"\n ~description:\n \"The submit batch would exceed the burn limit, we withdraw the submit.\"\n ~pp:(fun ppf (burn, limit) ->\n Format.fprintf\n ppf\n \"Cannot submit the batch of L2 operations as the cost (%a) would \\\n exceed the burn limit (%a)\"\n Tez_repr.pp\n burn\n Tez_repr.pp\n limit)\n Data_encoding.(\n obj2 (req \"burn\" Tez_repr.encoding) (req \"limit\" Tez_repr.encoding))\n (function\n | Submit_batch_burn_exceeded {burn; limit} -> Some (burn, limit)\n | _ -> None)\n (fun (burn, limit) -> Submit_batch_burn_exceeded {burn; limit}) ;\n (* Tx_rollup_inbox_does_not_exist *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_inbox_does_not_exist\"\n ~title:\"Missing transaction rollup inbox\"\n ~description:\"The transaction rollup does not have an inbox at this level\"\n ~pp:(fun ppf (addr, level) ->\n Format.fprintf\n ppf\n \"Transaction rollup %a does not have an inbox at level %a\"\n Tx_rollup_repr.pp\n addr\n Tx_rollup_level_repr.pp\n level)\n (obj2\n (req \"tx_rollup_address\" Tx_rollup_repr.encoding)\n (req \"raw_level\" Tx_rollup_level_repr.encoding))\n (function\n | Inbox_does_not_exist (rollup, level) -> Some (rollup, level) | _ -> None)\n (fun (rollup, level) -> Inbox_does_not_exist (rollup, level)) ;\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_inbox_size_would_exceed_limit\"\n ~title:\"Transaction rollup inbox\226\128\153s size would exceed the limit\"\n ~description:\n \"Transaction rollup inbox\226\128\153s size in bytes would exceed the limit\"\n ~pp:(fun ppf addr ->\n Format.fprintf\n ppf\n \"Adding the submitted message would make the inbox of %a exceed the \\\n authorized size in bytes at this level\"\n Tx_rollup_repr.pp\n addr)\n (obj1 (req \"tx_rollup_address\" Tx_rollup_repr.encoding))\n (function Inbox_size_would_exceed_limit rollup -> Some rollup | _ -> None)\n (fun rollup -> Inbox_size_would_exceed_limit rollup) ;\n (* Tx_rollup_message_count_would_exceed_limit *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_inbox_count_would_exceed_limit\"\n ~title:\"Transaction rollup inbox\226\128\153s message count would exceed the limit\"\n ~description:\n \"Transaction rollup inbox\226\128\153s message count would exceed the limit\"\n ~pp:(fun ppf addr ->\n Format.fprintf\n ppf\n \"Adding the submitted message would make the inbox of %a exceed the \\\n authorized message count at this level\"\n Tx_rollup_repr.pp\n addr)\n (obj1 (req \"tx_rollup_address\" Tx_rollup_repr.encoding))\n (function\n | Inbox_count_would_exceed_limit rollup -> Some rollup | _ -> None)\n (fun rollup -> Inbox_count_would_exceed_limit rollup) ;\n (* Tx_rollup_message_size_exceed_limit *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_no_uncommitted_inbox\"\n ~title:\"There is no inbox awaiting a commitment.\"\n ~description:\"There is no inbox awaiting a commitment.\"\n empty\n (function No_uncommitted_inbox -> Some () | _ -> None)\n (fun () -> No_uncommitted_inbox) ;\n (* Tx_rollup_message_size_exceed_limit *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_message_size_exceeds_limit\"\n ~title:\"A message submitted to a transaction rollup inbox exceeds limit\"\n ~description:\n \"A message submitted to a transaction rollup inbox exceeds limit\"\n empty\n (function Message_size_exceeds_limit -> Some () | _ -> None)\n (fun () -> Message_size_exceeds_limit) ;\n (* Tx_rollup_too_many_inboxes *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_too_many_inboxes\"\n ~title:\"Cannot create a new inbox because there are too many already\"\n ~description:\"Cannot create a new inbox because there are too many already\"\n empty\n (function Too_many_inboxes -> Some () | _ -> None)\n (fun () -> Too_many_inboxes) ;\n (* Tx_rollup_too_many_commitments *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_too_many_commitments\"\n ~title:\"Too many commitments\"\n ~description:\n \"Cannot create a new commitment because there are too many already\"\n empty\n (function Too_many_commitments -> Some () | _ -> None)\n (fun () -> Too_many_commitments) ;\n (* Tx_rollup_too_many_withdrawals *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_too_many_withdrawals\"\n ~title:\"Cannot dispatch that many withdrawals\"\n ~description:\"Cannot dispatch that many withdrawals\"\n empty\n (function Too_many_withdrawals -> Some () | _ -> None)\n (fun () -> Too_many_withdrawals) ;\n (* Wrong_batch_count *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_wrong_batch_count\"\n ~title:\"This commitment has the wrong number of batches\"\n ~description:\n \"This commitment has a different number of batches than its inbox\"\n unit\n (function Wrong_batch_count -> Some () | _ -> None)\n (fun () -> Wrong_batch_count) ;\n (* Commitment_too_early *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_commitment_too_early\"\n ~title:\"Cannot submit a commitment for this level yet\"\n ~description:\n \"It is not possible to submit a commitment for this level just yet.\"\n (obj2\n (req \"provided\" Tx_rollup_level_repr.encoding)\n (req \"expected\" Tx_rollup_level_repr.encoding))\n (function\n | Commitment_too_early {provided; expected} -> Some (provided, expected)\n | _ -> None)\n (fun (provided, expected) -> Commitment_too_early {provided; expected}) ;\n (* Level_already_has_commitment *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_level_already_has_commitment\"\n ~title:\"This commitment is for a level that already has a commitment\"\n ~description:\"This commitment is for a level that already has a commitment\"\n (obj1 (req \"level\" Tx_rollup_level_repr.encoding))\n (function Level_already_has_commitment level -> Some level | _ -> None)\n (fun level -> Level_already_has_commitment level) ;\n (* Wrong_inbox_hash *)\n register_error_kind\n `Branch\n ~id:\"Wrong_inbox_hash\"\n ~title:\"This commitment has the wrong inbox hash\"\n ~description:\"This commitment has a different hash than its inbox\"\n unit\n (function Wrong_inbox_hash -> Some () | _ -> None)\n (fun () -> Wrong_inbox_hash) ;\n (* Bond_does_not_exist *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_bond_does_not_exist\"\n ~title:\"This account does not have a bond for this rollup\"\n ~description:\"This account does not have a bond for this rollup\"\n (obj1 (req \"contract\" Signature.Public_key_hash.encoding))\n (function Bond_does_not_exist contract -> Some contract | _ -> None)\n (fun contract -> Bond_does_not_exist contract) ;\n (* Bond_in_use *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_bond_in_use\"\n ~title:\"This account's bond is in use for one or more commitments\"\n ~description:\"This account's bond is in use for one or more commitments\"\n (obj1 (req \"contract\" Signature.Public_key_hash.encoding))\n (function Bond_in_use contract -> Some contract | _ -> None)\n (fun contract -> Bond_in_use contract) ;\n (* No_commitment_to_finalize *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_no_commitment_to_finalize\"\n ~title:\"There is no commitment to finalize\"\n ~description:\"There is no commitment to finalize\"\n empty\n (function No_commitment_to_finalize -> Some () | _ -> None)\n (fun () -> No_commitment_to_finalize) ;\n (* No_commitment_to_remove *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_no_commitment_to_remove\"\n ~title:\"There is no commitment to remove\"\n ~description:\"There is no commitment to remove\"\n empty\n (function No_commitment_to_remove -> Some () | _ -> None)\n (fun () -> No_commitment_to_remove) ;\n (* Remove_commitment_too_early *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_remove_commitment_too_early\"\n ~title:\"It's too early to try to remove a commitment\"\n ~description:\"It's too early to try to remove the oldest final commitment\"\n empty\n (function Remove_commitment_too_early -> Some () | _ -> None)\n (fun () -> Remove_commitment_too_early) ;\n (* Commitment_does_not_exist *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_commitment_does_not_exist\"\n ~title:\"There is no commitment at the requested level\"\n ~description:\"There is no commitment at the requested level\"\n (obj1 (req \"provided\" Tx_rollup_level_repr.encoding))\n (function Commitment_does_not_exist l -> Some l | _ -> None)\n (fun l -> Commitment_does_not_exist l) ;\n (* Wrong_predecessor_hash *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_wrong_predecessor_hash\"\n ~title:\"The commitment refers to a commitment that is not in the context\"\n ~description:\n \"The commitment refers to a commitment that is not in the context\"\n (obj2\n (req \"provided\" (option Tx_rollup_commitment_repr.Hash.encoding))\n (req \"expected\" (option Tx_rollup_commitment_repr.Hash.encoding)))\n (function\n | Wrong_predecessor_hash {provided; expected} -> Some (provided, expected)\n | _ -> None)\n (fun (provided, expected) -> Wrong_predecessor_hash {provided; expected}) ;\n (* Tx_rollup_already_exists *)\n register_error_kind\n `Permanent\n ~id:\"tx_rollup_already_exists\"\n ~title:\"Transaction rollup was already created\"\n ~description:\n \"The protocol tried to originate the same transaction rollup twice\"\n ~pp:(fun ppf addr ->\n Format.fprintf\n ppf\n \"Transaction rollup %a is already used for an existing transaction \\\n rollup. This should not happen, and indicates there is a bug in the \\\n protocol. If you can, please report this bug \\\n (https://gitlab.com/tezos/tezos/-/issues.)\"\n Tx_rollup_repr.pp\n addr)\n (obj1 (req \"rollup_address\" Tx_rollup_repr.encoding))\n (function Tx_rollup_already_exists rollup -> Some rollup | _ -> None)\n (fun rollup -> Tx_rollup_already_exists rollup) ;\n (* Tx_rollup_does_not_exist *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_does_not_exist\"\n ~title:\"Transaction rollup does not exist\"\n ~description:\"An invalid transaction rollup address was submitted\"\n ~pp:(fun ppf addr ->\n Format.fprintf\n ppf\n \"Invalid transaction rollup address %a\"\n Tx_rollup_repr.pp\n addr)\n (obj1 (req \"rollup_address\" Tx_rollup_repr.encoding))\n (function Tx_rollup_does_not_exist rollup -> Some rollup | _ -> None)\n (fun rollup -> Tx_rollup_does_not_exist rollup) ;\n (* Internal_error *)\n register_error_kind\n `Permanent\n ~id:\"tx_rollup_internal_error\"\n ~title:\"An internal error occurred\"\n ~description:\"An internal error occurred\"\n (obj1 (req \"description\" (string Plain)))\n (function Internal_error str -> Some str | _ -> None)\n (fun str -> Internal_error str) ;\n (* Wrong_message_position *)\n register_error_kind\n `Branch\n ~id:\"tx_rollup_wrong_message_position\"\n ~title:\"Wrong message index in rejection\"\n ~description:\n \"The rejection references the {position}^th message of the inbox {l} \\\n which contains only {inbox_length} messages\"\n (obj3\n (req \"level\" Tx_rollup_level_repr.encoding)\n (req \"position\" int31)\n (req \"length\" int31))\n (function\n | Wrong_message_position {level; position; length} ->\n Some (level, position, length)\n | _ -> None)\n (fun (level, position, length) ->\n Wrong_message_position {level; position; length}) ;\n (* Wrong_path_depth *)\n register_error_kind\n `Permanent\n ~id:\"tx_rollup_wrong_message_path_depth\"\n ~title:\"Wrong message path depth\"\n ~description:\n \"A path submitted as argument of this operation exceeds the maximum \\\n depth that can be witnessed.\"\n (obj3\n (req\n \"target\"\n (union\n [\n case\n (Tag 0)\n ~title:\"Inbox\"\n (constant \"inbox\")\n (function `Inbox -> Some () | _ -> None)\n (fun () -> `Inbox);\n case\n (Tag 1)\n ~title:\"Commitment\"\n (constant \"commitment\")\n (function `Commitment -> Some () | _ -> None)\n (fun () -> `Commitment);\n ]))\n (req \"provided\" int31)\n (req \"limit\" int31))\n (function\n | Wrong_path_depth {kind; provided; limit} -> Some (kind, provided, limit)\n | _ -> None)\n (fun (kind, provided, limit) -> Wrong_path_depth {kind; provided; limit}) ;\n (* Wrong_message_hash *)\n register_error_kind\n `Branch\n ~id:\"tx_rollup_wrong_message_path\"\n ~title:\"Wrong message path in rejection.\"\n ~description:\n \"This rejection has sent a message and a path that does not fit the \\\n current merkle root hash in the corresponding inbox\"\n (obj1\n (req \"expected_merkle_root\" Tx_rollup_inbox_repr.Merkle.root_encoding))\n (function Wrong_message_path {expected} -> Some expected | _ -> None)\n (fun expected -> Wrong_message_path {expected}) ;\n (* No_finalized_commitment_for_level *)\n register_error_kind\n `Temporary\n ~id:\"operation.tx_rollup_no_finalized_commitment_for_level\"\n ~title:\"Operation is about a commitment that is not yet finalized\"\n ~description:\"This operation must be about a finalized commitment\"\n ~pp:(fun ppf (level, window) ->\n match window with\n | Some (first, last) ->\n Format.fprintf\n ppf\n \"This operation is only allowed on finalized and existing \\\n commitments, but its level %a is not in the existing and \\\n finalized window of commitments: [%a; %a].\"\n Tx_rollup_level_repr.pp\n level\n Tx_rollup_level_repr.pp\n first\n Tx_rollup_level_repr.pp\n last\n | None ->\n Format.fprintf\n ppf\n \"This operation was about level %a but no finalized commitment \\\n exists yet.\"\n Tx_rollup_level_repr.pp\n level)\n Data_encoding.(\n obj2\n (req \"received\" Tx_rollup_level_repr.encoding)\n (req\n \"commitment_head_level\"\n (option\n (tup2 Tx_rollup_level_repr.encoding Tx_rollup_level_repr.encoding))))\n (function\n | No_finalized_commitment_for_level {level; window} -> Some (level, window)\n | _ -> None)\n (fun (level, window) -> No_finalized_commitment_for_level {level; window}) ;\n (* Withdraw_invalid_proof *)\n register_error_kind\n `Branch\n ~id:\"tx_rollup_withdraw_invalid_path\"\n ~title:\"The validation path submitted for a withdrawal is invalid\"\n ~description:\n \"The validation path submitted for a withdrawal is not valid for the \\\n given withdrawal and message index\"\n empty\n (function Withdraw_invalid_path -> Some () | _ -> None)\n (fun () -> Withdraw_invalid_path) ;\n (* Withdrawals_invalid_path *)\n register_error_kind\n `Branch\n ~id:\"tx_rollup_withdrawals_invalid_path\"\n ~title:\"The validation path submitted for a withdrawal is invalid\"\n ~description:\n \"The validation path submitted for a withdrawal is not valid for the \\\n given withdrawal and message index\"\n empty\n (function Withdrawals_invalid_path -> Some () | _ -> None)\n (fun () -> Withdrawals_invalid_path) ;\n (* Withdrawals_already_dispatched *)\n register_error_kind\n `Branch\n ~id:\"operation.withdrawals_already_dispatched\"\n ~title:\"withdrawals already dispatched\"\n ~description:\n \"The withdrawals have already been dispatched to their layer-1 \\\n beneficiary\"\n Data_encoding.unit\n (function Withdrawals_already_dispatched -> Some () | _ -> None)\n (fun () -> Withdrawals_already_dispatched) ;\n register_error_kind\n `Temporary\n ~id:\"operation.withdraw_already_consumed\"\n ~title:\"withdraw already consumed\"\n ~description:\"The submitted withdraw has already been consumed\"\n ~pp:(fun ppf () ->\n Format.fprintf\n ppf\n \"The submitted withdraw exists but it has already been consumed \\\n earlier.\")\n Data_encoding.unit\n (function Withdraw_already_consumed -> Some () | _ -> None)\n (fun () -> Withdraw_already_consumed) ;\n (* Invalid_committer *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_invalid_committer\"\n ~title:\"Committer cannot propose a commitment for this level\"\n ~description:\n \"The committer is trying to propose a commitment, but their bond is \\\n about to be slashed because a commitment they authored will be \\\n overwritten.\"\n Data_encoding.unit\n (function Invalid_committer -> Some () | _ -> None)\n (fun () -> Invalid_committer) ;\n register_error_kind\n `Permanent\n ~id:\"tx_rollup_commitment_bond_negative\"\n ~title:\n \"The number of commitments associated with an implicit account is \\\n negative\"\n ~description:\n \"A negative number of commitment is associated with an implicit account \\\n and its associated bound. This error is internal and should never \\\n happen.\"\n ~pp:(fun ppf count ->\n Format.fprintf\n ppf\n \"The number of commitments %d associated with this implicit account is \\\n negative\"\n count)\n (obj1 (req \"count\" Data_encoding.int31))\n (function Commitment_bond_negative count -> Some count | _ -> None)\n (fun count -> Commitment_bond_negative count) ;\n (* Cannot_reject_level *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_cannot_reject_level\"\n ~title:\"Cannot reject a commitment at the requested level\"\n ~description:\"Cannot reject a commitment at the requested level\"\n (obj2\n (req \"provided\" Tx_rollup_level_repr.encoding)\n (req\n \"accepted_range\"\n (option\n (obj2\n (req \"min\" Tx_rollup_level_repr.encoding)\n (req \"max\" Tx_rollup_level_repr.encoding)))))\n (function\n | Cannot_reject_level {provided; accepted_range} ->\n Some (provided, accepted_range)\n | _ -> None)\n (fun (provided, accepted_range) ->\n Cannot_reject_level {provided; accepted_range}) ;\n (* Wrong_rejection_hash *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_wrong_rejection_hashes\"\n ~title:\n \"The message result hash recomputed from the rejection argument is \\\n invalid\"\n ~description:\n \"The message result hash recomputed from the rejection argument is \\\n invalid\"\n (obj2\n (req \"provided\" Tx_rollup_message_result_hash_repr.encoding)\n (req\n \"expected\"\n (union\n [\n case\n (Tag 0)\n ~title:\"hash\"\n Tx_rollup_message_result_hash_repr.encoding\n (function `Hash h -> Some h | _ -> None)\n (fun h -> `Hash h);\n case\n (Tag 1)\n ~title:\"valid_path\"\n (obj2\n (req \"root\" Tx_rollup_commitment_repr.Merkle_hash.encoding)\n (req \"index\" int31))\n (function `Valid_path (h, i) -> Some (h, i) | _ -> None)\n (fun (h, i) -> `Valid_path (h, i));\n ])))\n (function\n | Wrong_rejection_hash {provided; expected} -> Some (provided, expected)\n | _ -> None)\n (fun (provided, expected) -> Wrong_rejection_hash {provided; expected}) ;\n (* ticket_payload_size_limit_exceeded *)\n register_error_kind\n `Permanent\n ~id:\"tx_rollup_ticket_payload_size_limit_exceeded\"\n ~title:\"The payload of the deposited ticket exceeded the size limit\"\n ~description:\"The payload of the deposited ticket exceeded the size limit\"\n (obj2 (req \"payload_size\" Saturation_repr.n_encoding) (req \"limit\" int31))\n (function\n | Ticket_payload_size_limit_exceeded {payload_size; limit} ->\n Some (payload_size, limit)\n | _ -> None)\n (fun (payload_size, limit) ->\n Ticket_payload_size_limit_exceeded {payload_size; limit}) ;\n register_error_kind\n `Permanent\n ~id:\"tx_rollup_proof_undecodable\"\n ~title:\"Could not decode the proof\"\n ~description:\"The proof submitted as argument could not be decoded\"\n empty\n (function Proof_undecodable -> Some () | _ -> None)\n (fun () -> Proof_undecodable) ;\n (* Proof_failed_to_reject *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_proof_failed_to_reject\"\n ~title:\"Proof failed to reject the commitment\"\n ~description:\n \"The proof verification failed and was unable to reject the commitment\"\n empty\n (function Proof_failed_to_reject -> Some () | _ -> None)\n (fun () -> Proof_failed_to_reject) ;\n (* Proof_produced_rejected_state *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_proof_produced_rejected_state\"\n ~title:\"Proof produced the rejected state\"\n ~description:\n \"The proof submitted did not refute the rejected commitment. The proof \\\n produced the same committed state\"\n empty\n (function Proof_produced_rejected_state -> Some () | _ -> None)\n (fun () -> Proof_produced_rejected_state) ;\n (* Proof_invalid_before *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_proof_invalid_before\"\n ~title:\"Proof started from an invalid hash\"\n ~description:\n \"The proof started from a hash which is not the one agreed on (i.e. in \\\n the previous commitment)\"\n (obj2\n (req \"agreed\" Context_hash.encoding)\n (req \"provided\" Context_hash.encoding))\n (function\n | Proof_invalid_before {agreed; provided} -> Some (agreed, provided)\n | _ -> None)\n (fun (agreed, provided) -> Proof_invalid_before {agreed; provided}) ;\n register_error_kind\n `Permanent\n ~id:\"tx_rollup_no_withdrawals_to_dispatch\"\n ~title:\"Trying to dispatch withdrawals when none happened\"\n ~description:\"Cannot dispatch an empty list of withdrawals\"\n empty\n (function No_withdrawals_to_dispatch -> Some () | _ -> None)\n (fun () -> No_withdrawals_to_dispatch)\n" ;
} ;
{ name = "Tx_rollup_state_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** The state of a transaction rollup is a set of variables whose values vary\n in time, as the rollup progresses. *)\ntype t\n\n(** [initial_state pre_allocated_storage] returns the initial state of\n a transaction rollup (after its origination) with\n [pre_allocated_storage] bytes of storage already paid for. *)\nval initial_state : pre_allocated_storage:Z.t -> t\n\nval encoding : t Data_encoding.t\n\nval pp : Format.formatter -> t -> unit\n\n(** [update_burn_per_byte state ~elapsed ~factor ~final_size\n ~hard_limit] updates the cost per byte to be paid for each message\n submitted to the rollup. This is done by computing a moving\n average for [factor] snapshots. Each snapshot being the size of the\n total messages for the rollup. Hence each snapshot contributes to\n [1/(1 + factor)] to the average.\n\n It may happen that the rollup does not receive any message for\n some period of time. The parameter [elapsed] allows that to be taken\n into account. If [elapsed=n] with [n>=1] it is similar as if\n [update_burn_per_byte] was called [n] times with [final_size=0].\n\n Once the exponential moving average [ema] is computed, we use the\n [hard limit] to know whether the cost per byte should be updated:\n\n 1. If [ema <= 80] then the cost per byte is decreased\n\n 2. If [80 < ema <= 90] then the cost per byte is stable\n\n 3. If [90 < ema] then the cost ber byte is increased\n\n The rationale behind this mechanics is to adapt the cost of a\n transactional rollup depending on its activity. This can be used\n to prevent from some spamming attacks. *)\nval update_burn_per_byte :\n t -> elapsed:int -> factor:int -> final_size:int -> hard_limit:int -> t\n\n(** [burn_cost ~limit state size] computes the burn to be paid to submit\n [size] bytes in the inbox of the transactional rollup.\n\n Returns [Tx_rollup_submit_batch_burn_exceeded] if the (computed) burn\n exceeds [limit].\n*)\nval burn_cost : limit:Tez_repr.t option -> t -> int -> Tez_repr.t tzresult\n\n(** [has_valid_commitment_at state level] returns [true] iff there is\n a valid commitment for [level] in the layer-1 storage.\n\n On the contrary, if there is not commitment for [level] in the\n layer-1 storage, or if there exists an orphan commitment (that is,\n a commitment which has been rejected, or with one of its ancestors\n that has been rejected) at [level], this function returns\n [false]. *)\nval has_valid_commitment_at : t -> Tx_rollup_level_repr.t -> bool\n\n(** [uncommitted_inboxes_count state] returns the number of inboxes\n the rollup current has in the storage which did not receive a\n commitment yet. *)\nval uncommitted_inboxes_count : t -> int\n\n(** [commitments_count t] returns the number of commitment still in\n the layer-1 context. *)\nval commitments_count : t -> int\n\n(** [inboxes_count state] returns the number of inboxes the rollup\n current has in the storage. *)\nval inboxes_count : t -> int\n\n(** [next_commitment_to_finalize state] returns the rollup level of\n the next commitment to be finalized. *)\nval next_commitment_to_finalize : t -> Tx_rollup_level_repr.t option\n\n(** [next_commitment_to_remove state] returns the rollup level of the\n next commitment to be removed from the layer-1 context. *)\nval next_commitment_to_remove : t -> Tx_rollup_level_repr.t option\n\n(** [finalized_commitment_oldest_level state] returns the rollup level\n of the oldest finalized commitment. *)\nval finalized_commitment_oldest_level : t -> Tx_rollup_level_repr.t option\n\n(** [next_commitment_level current_level state] returns the expected\n level of the next valid commitment.\n\n This function can return the error [No_uncommitted_inbox] if\n there is no inbox awaiting a commitment. *)\nval next_commitment_level :\n t -> Raw_level_repr.t -> Tx_rollup_level_repr.t tzresult\n\n(** [next_commitment_predecessor state] returns the expected\n predecessor hash of the next valid commitment. *)\nval next_commitment_predecessor : t -> Tx_rollup_commitment_repr.Hash.t option\n\n(** [record_inbox_creation state level] updates the state of a rollup\n to take into account the creation of of a new inbox at the given\n Tezos [level], and returns the rollup level to associate to this\n inbox and the number of bytes allocated for the inbox.\n\n This function may return an [Internal_error] iff an inbox has\n already been created at a level greater (or equal) than\n [level]. It is the responsibility of the caller to avoid that. *)\nval record_inbox_creation :\n t -> Raw_level_repr.t -> (t * Tx_rollup_level_repr.t * Z.t) tzresult\n\n(** [record_inbox_deletion state level] updates [state] to take into\n account the deletion of the inbox stored at Tezos [level] from the\n storage.\n\n This function returns an [Internal_error] iff there is no inbox\n in the storage of the layer-1, or if [level] is not the oldest\n level of rollup. *)\nval record_inbox_deletion : t -> Tx_rollup_level_repr.t -> t tzresult\n\n(** [record_commitment_creation state level] updates [state] to take\n into account the creation of a commitment at a given Tezos\n [level].\n\n This function returns an [Internal_error] if [level] is not the\n successor level of the current commitment head, or if [level] is\n greater than the inbox head. *)\nval record_commitment_creation :\n t -> Tx_rollup_level_repr.t -> Tx_rollup_commitment_repr.Hash.t -> t tzresult\n\n(** [record_commitment_rejection state level pred_hash] updates\n [state] to take into account the fact that the commitment for the\n inbox at [level] has been rejected.\n\n The caller is expected to provide the predecessor hash the next\n valid commitment needs to use. It can be omitted under two\n circumstances: if [level = root], or if the commitment identified\n by [pred_hash] is no longer in the layer-1 context. *)\nval record_commitment_rejection :\n t ->\n Tx_rollup_level_repr.t ->\n Tx_rollup_commitment_repr.Hash.t option ->\n t tzresult\n\n(** [record_commitment_deletion state level msg_hash commitment_hash]\n updates [state] to take into account the deletion of a commitment\n at a given rollup [level], and of given [commitment_hash] and\n whose last message commitment is [msg_hash].\n\n This function returns an [Internal_error] if [level] is not the\n commitment tail, that is the oldest finalized commitment. *)\nval record_commitment_deletion :\n t ->\n Tx_rollup_level_repr.t ->\n Tx_rollup_commitment_repr.Hash.t ->\n Tx_rollup_message_result_hash_repr.t ->\n t tzresult\n\n(** [finalized_commitments_range state] returns the window of finalized\n commitments that have not yet been cleaned out\n\n This function returns an [Internal_error] if the state is inconsistent,\n which should not be possible. *)\nval finalized_commitments_range :\n t -> (Tx_rollup_level_repr.t * Tx_rollup_level_repr.t) option\n\n(** [check_level_can_be_rejected state level] raises\n [Cannot_reject_level] iff there does not exist a commitment at\n [level] that is not yet finalized. *)\nval check_level_can_be_rejected : t -> Tx_rollup_level_repr.t -> unit tzresult\n\n(** [last_removed_commitment_hashes state] returns two hashes\n associated to the last removed commitment: the message result\n hash and the last commitment hash. *)\nval last_removed_commitment_hashes :\n t ->\n (Tx_rollup_message_result_hash_repr.t * Tx_rollup_commitment_repr.Hash.t)\n option\n\n(** [head_levels state] returns the level of the last inbox which has\n been created in the layer-1 context, along with the Tezos level at\n which said inbox has been created. *)\nval head_levels : t -> (Tx_rollup_level_repr.t * Raw_level_repr.t) option\n\n(** [adjust_storage_allocation state ~delta] accounts for a change in\n [delta] number of bytes used storage space by a transaction rollup.\n\n A positive [delta] indicates that the occupied storage of the\n rollup increased. A negative [delta] indicates that the\n occupied storage of the rollup decreased.\n\n Along with an updated state, a diff of storage space\n is returned. The diff is\n [max(0, allocated_storage - (occupied_storage + delta))].\n That is, 0 if no new storage was allocated, and the number of bytes\n allocated otherwise.\n\n This function returns [Tx_rollup_errors.Internal_error] if\n submitted [delta] would make [occupied_storage] negative. *)\nval adjust_storage_allocation : t -> delta:Z.t -> (t * Z.t) tzresult\n\nmodule Internal_for_tests : sig\n (** [make] returns a state for tests *)\n val make :\n ?burn_per_byte:Tez_repr.t ->\n ?inbox_ema:int ->\n ?last_removed_commitment_hashes:\n Tx_rollup_message_result_hash_repr.t * Tx_rollup_commitment_repr.Hash.t ->\n ?finalized_commitments:Tx_rollup_level_repr.t * Tx_rollup_level_repr.t ->\n ?unfinalized_commitments:Tx_rollup_level_repr.t * Tx_rollup_level_repr.t ->\n ?uncommitted_inboxes:Tx_rollup_level_repr.t * Tx_rollup_level_repr.t ->\n ?commitment_newest_hash:Tx_rollup_commitment_repr.Hash.t ->\n ?tezos_head_level:Raw_level_repr.t ->\n ?occupied_storage:Z.t ->\n ?commitments_watermark:Tx_rollup_level_repr.t ->\n allocated_storage:Z.t ->\n unit ->\n t\n\n val get_inbox_ema : t -> int\n\n val get_occupied_storage : t -> Z.t\n\n val set_occupied_storage : Z.t -> t -> t\n\n val get_allocated_storage : t -> Z.t\n\n val set_allocated_storage : Z.t -> t -> t\n\n val reset_commitments_watermark : t -> t\n\n val get_commitments_watermark : t -> Tx_rollup_level_repr.t option\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Tx_rollup_errors_repr\n\ntype range =\n | Interval of {\n oldest : Tx_rollup_level_repr.t;\n newest : Tx_rollup_level_repr.t;\n }\n | Empty of {next : Tx_rollup_level_repr.t}\n\nlet range_newest = function Interval {newest; _} -> Some newest | _ -> None\n\nlet range_oldest = function Interval {oldest; _} -> Some oldest | _ -> None\n\nlet extend = function\n | Empty {next} -> (Interval {oldest = next; newest = next}, next)\n | Interval {oldest; newest} ->\n let newest = Tx_rollup_level_repr.succ newest in\n (Interval {oldest; newest}, newest)\n\nlet shrink = function\n | Empty _ -> error (Internal_error \"cannot shrink range\")\n | Interval {oldest; newest} when Tx_rollup_level_repr.(oldest < newest) ->\n ok (Interval {oldest = Tx_rollup_level_repr.succ oldest; newest})\n | Interval {newest; oldest = _} ->\n ok (Empty {next = Tx_rollup_level_repr.succ newest})\n\nlet belongs_to range level =\n match range with\n | Empty _ -> false\n | Interval {oldest; newest} ->\n Tx_rollup_level_repr.(oldest <= level && level <= newest)\n\nlet right_cut range level =\n match Tx_rollup_level_repr.pred level with\n | None -> ok (Empty {next = Tx_rollup_level_repr.root})\n | Some predecessor -> (\n match range with\n | Interval {oldest; newest = _} when belongs_to range level ->\n if Tx_rollup_level_repr.(oldest <= predecessor) then\n ok (Interval {oldest; newest = predecessor})\n else ok (Empty {next = level})\n | _ -> error (Internal_error \"cannot cut range\"))\n\nlet left_extend range level =\n match range with\n | Interval {oldest = _; newest} -> ok (Interval {oldest = level; newest})\n | Empty {next} ->\n let newest =\n Option.value ~default:level (Tx_rollup_level_repr.pred next)\n in\n ok (Interval {oldest = level; newest})\n\nlet range_count = function\n | Empty _ -> 0\n | Interval {oldest; newest} ->\n Int32.(succ @@ Tx_rollup_level_repr.diff newest oldest |> to_int)\n\nlet range_encoding : range Data_encoding.t =\n Data_encoding.(\n union\n [\n case\n (Tag 0)\n ~title:\"empty\"\n (obj1 (req \"next\" Tx_rollup_level_repr.encoding))\n (function Empty {next} -> Some next | _ -> None)\n (fun next -> Empty {next});\n case\n (Tag 1)\n ~title:\"interval\"\n (obj2\n (req \"newest\" Tx_rollup_level_repr.encoding)\n (req \"oldest\" Tx_rollup_level_repr.encoding))\n (function\n | Interval {newest; oldest} -> Some (newest, oldest) | _ -> None)\n (fun (newest, oldest) -> Interval {newest; oldest});\n ])\n\nlet pp_range fmt = function\n | Empty {next} -> Format.(fprintf fmt \"next: %a\" Tx_rollup_level_repr.pp next)\n | Interval {oldest; newest} ->\n Format.(\n fprintf\n fmt\n \"oldest: %a newest: %a\"\n Tx_rollup_level_repr.pp\n oldest\n Tx_rollup_level_repr.pp\n newest)\n\ntype watermark = Tx_rollup_level_repr.t option\n\nlet is_above_watermark watermark level =\n match watermark with\n | Some watermark -> Tx_rollup_level_repr.(watermark < level)\n | None -> true\n\nlet make_watermark level = Some level\n\n(** The state of a transaction rollup is composed of [burn_per_byte]\n and [inbox_ema] fields. [initial_state] introduces their initial\n values. Both values are updated by [update_burn_per_byte] as the\n rollup progresses.\n\n [burn_per_byte] state the cost of burn per byte to be paid for\n each byte submitted to a transaction rollup inbox. [inbox_ema]\n is a key factor to impact the update of [burn_per_byte].\n\n [inbox_ema] is the N-block EMA to react to recent N-inbox size\n changes. N-block EMA is an exponential moving average (EMA), that\n is a type of moving average that places a greater weight and\n significance on the most N data points. The purpose of [inbox_ema]\n is to get lessened volatility of burn, that is more resistant to\n spurious spikes of [burn_per_byte].\n\n The state of the transaction rollup also keeps track of four pointers\n to four different rollup levels.\n\n - The [commitment_oldest_level] is the level of the oldest\n finalized commitment still stored in the layer-1 storage.\n\n - The [commitment_newest_level] is the level of the most recent\n unfinalized commitment in the layer-1 storage.\n\n - The [oldest_inbox_level] is the level of the oldest inbox still stored\n in the layer-1 storage.\n\n - The [newest_level] is the level of the most recent inbox in the\n layer-1 storage.\n*)\ntype t = {\n last_removed_commitment_hashes :\n (Tx_rollup_message_result_hash_repr.t * Tx_rollup_commitment_repr.Hash.t)\n option;\n finalized_commitments : range;\n unfinalized_commitments : range;\n uncommitted_inboxes : range;\n commitment_newest_hash : Tx_rollup_commitment_repr.Hash.t option;\n tezos_head_level : Raw_level_repr.t option;\n burn_per_byte : Tez_repr.t;\n inbox_ema : int;\n allocated_storage : Z.t;\n occupied_storage : Z.t;\n commitments_watermark : watermark;\n}\n\n(*\n\n The main use of a transaction rollup state is to keep track of four\n pointers to four different rollup levels (see above).\n\n When the rollup is created, these four pointers are initialized with\n the [None] value, because no inboxes or commitments have been created\n yet. Because inboxes and commitments can be removed from the layer-1\n context under certain circumstances, they can be reset to [None].\n\n The state allows us to keep track of three intervals: the finalized\n commitments (whose inboxes have been removed from the layer-1\n storage), the unfinalized commitments (whose inboxes are still in\n the layer-1 storage), and uncommitted inboxes (that is, inboxes\n which are still waiting for a commitment).\n\n finalized uncommitted\n ^^^^^^ ^^^^^^^^\n [------------] commitments\n [--------------] inboxes\n ^^^^^^^^\n unfinalized\n\n Note that this layout is not the only one that we can witness in\n the layer-1 storage, even if it is the more common. It is possible\n for instance that there is no unfinalized commitments at a given\n time.\n\n finalized\n ^^^^^^\n [----] commitments\n [--------------] inboxes\n ^^^^^^^^^^^^^^^^\n uncommitted\n\n Or that we have no more inboxes, but only finalized commitments.\n\n finalized\n ^^^^^^\n CT\n [-----] commitments\n inboxes\n\n *)\n\nlet initial_state ~pre_allocated_storage =\n {\n last_removed_commitment_hashes = None;\n finalized_commitments = Empty {next = Tx_rollup_level_repr.root};\n unfinalized_commitments = Empty {next = Tx_rollup_level_repr.root};\n uncommitted_inboxes = Empty {next = Tx_rollup_level_repr.root};\n commitment_newest_hash = None;\n tezos_head_level = None;\n burn_per_byte = Tez_repr.zero;\n inbox_ema = 0;\n allocated_storage = pre_allocated_storage;\n occupied_storage = Z.zero;\n commitments_watermark = None;\n }\n\nlet encoding : t Data_encoding.t =\n let open Data_encoding in\n conv\n (fun {\n last_removed_commitment_hashes;\n finalized_commitments;\n unfinalized_commitments;\n uncommitted_inboxes;\n commitment_newest_hash;\n tezos_head_level;\n burn_per_byte;\n allocated_storage;\n occupied_storage;\n inbox_ema;\n commitments_watermark;\n } ->\n ( ( last_removed_commitment_hashes,\n finalized_commitments,\n unfinalized_commitments,\n uncommitted_inboxes,\n commitment_newest_hash,\n tezos_head_level,\n burn_per_byte,\n allocated_storage,\n occupied_storage,\n inbox_ema ),\n commitments_watermark ))\n (fun ( ( last_removed_commitment_hashes,\n finalized_commitments,\n unfinalized_commitments,\n uncommitted_inboxes,\n commitment_newest_hash,\n tezos_head_level,\n burn_per_byte,\n allocated_storage,\n occupied_storage,\n inbox_ema ),\n commitments_watermark ) ->\n {\n last_removed_commitment_hashes;\n finalized_commitments;\n unfinalized_commitments;\n uncommitted_inboxes;\n commitment_newest_hash;\n tezos_head_level;\n burn_per_byte;\n allocated_storage;\n occupied_storage;\n inbox_ema;\n commitments_watermark;\n })\n (merge_objs\n (obj10\n (req\n \"last_removed_commitment_hashes\"\n (option\n @@ obj2\n (req\n \"last_message_hash\"\n Tx_rollup_message_result_hash_repr.encoding)\n (req\n \"commitment_hash\"\n Tx_rollup_commitment_repr.Hash.encoding)))\n (req \"finalized_commitments\" range_encoding)\n (req \"unfinalized_commitments\" range_encoding)\n (req \"uncommitted_inboxes\" range_encoding)\n (req\n \"commitment_newest_hash\"\n (option Tx_rollup_commitment_repr.Hash.encoding))\n (req \"tezos_head_level\" (option Raw_level_repr.encoding))\n (req \"burn_per_byte\" Tez_repr.encoding)\n (req \"allocated_storage\" n)\n (req \"occupied_storage\" n)\n (req \"inbox_ema\" int31))\n (obj1\n (req \"commitments_watermark\" @@ option Tx_rollup_level_repr.encoding)))\n\nlet pp fmt\n {\n last_removed_commitment_hashes;\n finalized_commitments;\n unfinalized_commitments;\n uncommitted_inboxes;\n commitment_newest_hash;\n tezos_head_level;\n burn_per_byte;\n allocated_storage;\n occupied_storage;\n inbox_ema;\n commitments_watermark;\n } =\n Format.(\n fprintf\n fmt\n \"cost_per_byte: %a inbox_ema: %d finalized_commitments: %a \\\n unfinalized_commitments: %a uncommitted_inboxes: %a \\\n commitment_newest_hash: %a tezos_head_level: %a \\\n last_removed_commitment_hashes: %a allocated_storage: %a \\\n occupied_storage: %a commitments_watermark: %a\"\n Tez_repr.pp\n burn_per_byte\n inbox_ema\n pp_range\n finalized_commitments\n pp_range\n unfinalized_commitments\n pp_range\n uncommitted_inboxes\n (pp_print_option Tx_rollup_commitment_repr.Hash.pp)\n commitment_newest_hash\n (pp_print_option Raw_level_repr.pp)\n tezos_head_level\n (pp_print_option (fun fmt (m, c) ->\n fprintf\n fmt\n \"(message result: %a, commitment: %a)\"\n Tx_rollup_message_result_hash_repr.pp\n m\n Tx_rollup_commitment_repr.Hash.pp\n c))\n last_removed_commitment_hashes\n Z.pp_print\n allocated_storage\n Z.pp_print\n occupied_storage\n (pp_print_option Tx_rollup_level_repr.pp)\n commitments_watermark)\n\nlet adjust_storage_allocation : t -> delta:Z.t -> (t * Z.t) tzresult =\n fun state ~delta ->\n if Z.(equal zero delta) then ok (state, Z.zero)\n else\n let occupied_storage' = Z.add state.occupied_storage delta in\n if Compare.Z.(occupied_storage' < Z.zero) then\n (* returns [Internal_error] if [delta < 0] and [| delta | > state.occupied_storage].\n This error should never happen. *)\n error\n @@ Internal_error\n \"Storage size should be positive after occupied space is freed.\"\n else\n let diff = Z.sub occupied_storage' state.allocated_storage in\n if Compare.Z.(diff > Z.zero) then\n let state =\n {\n state with\n occupied_storage = occupied_storage';\n allocated_storage = occupied_storage';\n }\n in\n ok (state, diff)\n else\n let state = {state with occupied_storage = occupied_storage'} in\n ok (state, Z.zero)\n\nlet update_burn_per_byte_helper :\n t -> factor:int -> final_size:int -> hard_limit:int -> t =\n fun ({burn_per_byte; inbox_ema; _} as state) ~factor ~final_size ~hard_limit ->\n let threshold_increase = 90 in\n let threshold_decrease = 80 in\n let variation_factor = 5L in\n let smoothing = 2 in\n (* The formula of the multiplier of EMA :\n\n smoothing / (1 + N)\n\n Suppose the period we want to observe is given by the\n [factor]. The common choice of smoothing is 2.\n *)\n let inbox_ema =\n inbox_ema + ((final_size - inbox_ema) * smoothing / (1 + factor))\n in\n let percentage = inbox_ema * 100 / hard_limit in\n let computation =\n let open Compare.Int in\n if threshold_decrease < percentage && percentage <= threshold_increase then\n (* constant case *)\n ok burn_per_byte\n else\n Tez_repr.(burn_per_byte *? variation_factor >>? fun x -> x /? 100L)\n >>? fun variation ->\n let variation =\n if Tez_repr.(variation = zero) then Tez_repr.one_mutez else variation\n in\n (* increase case *)\n if threshold_increase < percentage then\n Tez_repr.(burn_per_byte +? variation)\n else if percentage < threshold_decrease && Tez_repr.(zero < burn_per_byte)\n then\n (* decrease case, and strictly positive burn *)\n Tez_repr.(burn_per_byte -? variation)\n else (* decrease case, and burn equals zero *)\n ok burn_per_byte\n in\n match computation with\n | Ok burn_per_byte -> {state with burn_per_byte; inbox_ema}\n (* In the (very unlikely) event of an overflow, we force the burn to\n be the maximum amount. *)\n | Error _ -> {state with burn_per_byte = Tez_repr.max_mutez; inbox_ema}\n\nlet rec update_burn_per_byte :\n t -> elapsed:int -> factor:int -> final_size:int -> hard_limit:int -> t =\n fun state ~elapsed ~factor ~final_size ~hard_limit ->\n (* factor is expected to be a low number ~ 100 *)\n if Compare.Int.(elapsed > factor) then\n (* We do not need to compute precisely the new state. *)\n {state with burn_per_byte = Tez_repr.zero; inbox_ema = 0}\n else if Compare.Int.(elapsed <= 0) then\n (* Base case, we take into a account the [final_size] once. *)\n update_burn_per_byte_helper state ~factor ~final_size ~hard_limit\n else\n (* For all the blocks that do not contain inboxes, we act as if\n the inbox size was [0]. *)\n let state' =\n update_burn_per_byte_helper state ~factor ~final_size:0 ~hard_limit\n in\n let elapsed = elapsed - 1 in\n update_burn_per_byte state' ~elapsed ~factor ~final_size ~hard_limit\n\nlet has_valid_commitment_at {finalized_commitments; unfinalized_commitments; _}\n level =\n belongs_to finalized_commitments level\n || belongs_to unfinalized_commitments level\n\nlet inboxes_count {unfinalized_commitments; uncommitted_inboxes; _} =\n range_count unfinalized_commitments + range_count uncommitted_inboxes\n\nlet uncommitted_inboxes_count {uncommitted_inboxes; _} =\n range_count uncommitted_inboxes\n\nlet commitments_count {finalized_commitments; unfinalized_commitments; _} =\n range_count unfinalized_commitments + range_count finalized_commitments\n\nlet record_inbox_creation t level =\n (match t.tezos_head_level with\n | Some tezos_lvl ->\n error_when\n Raw_level_repr.(level <= tezos_lvl)\n (Internal_error \"Trying to create an inbox in the past\")\n | None -> ok ())\n >>? fun () ->\n let uncommitted_inboxes, new_level = extend t.uncommitted_inboxes in\n adjust_storage_allocation t ~delta:Tx_rollup_inbox_repr.size\n >>? fun (t, diff) ->\n ok\n ( {t with tezos_head_level = Some level; uncommitted_inboxes},\n new_level,\n diff )\n\nlet next_commitment_predecessor state = state.commitment_newest_hash\n\nlet finalized_commitment_oldest_level state =\n range_oldest state.finalized_commitments\n\nlet next_commitment_level state current_level =\n match\n ( range_oldest state.uncommitted_inboxes,\n range_newest state.uncommitted_inboxes )\n with\n | Some oldest_level, Some newest_level -> (\n if\n (* We want to return an error if there is only one inbox in the\n storage, and this inbox has been created in the current\n block. *)\n Tx_rollup_level_repr.(oldest_level < newest_level)\n then\n (* If [oldest_level < newest_level], we know we are not in\n this setup, and we can safely return [oldest_level]. *)\n ok oldest_level\n else\n (* Otherwise, we know that [oldest_level = newest_level], and we\n need to check at which Tezos level is has been created. *)\n match state.tezos_head_level with\n | Some newest_inbox_creation ->\n error_when\n Raw_level_repr.(current_level <= newest_inbox_creation)\n No_uncommitted_inbox\n >>? fun () -> ok oldest_level\n | None -> error (Internal_error \"tezos_head_level was not properly set\")\n )\n | None, None -> error No_uncommitted_inbox\n | Some _, None | None, Some _ ->\n error (Internal_error \"rollup state is inconsistent\")\n\nlet next_commitment_to_finalize state =\n range_oldest state.unfinalized_commitments\n\nlet next_commitment_to_remove state = range_oldest state.finalized_commitments\n\nlet record_inbox_deletion state candidate =\n match range_oldest state.unfinalized_commitments with\n | Some level when Tx_rollup_level_repr.(candidate = level) ->\n shrink state.unfinalized_commitments >>? fun unfinalized_commitments ->\n let finalized_commitments, _ = extend state.finalized_commitments in\n ok {state with unfinalized_commitments; finalized_commitments}\n | _ -> error (Internal_error \"Trying to delete the wrong inbox\")\n\nlet record_commitment_creation state level hash =\n match range_oldest state.uncommitted_inboxes with\n | Some oldest ->\n error_unless\n Tx_rollup_level_repr.(level = oldest)\n (Internal_error \"Trying to create the wrong commitment\")\n >>? fun () ->\n shrink state.uncommitted_inboxes >>? fun uncommitted_inboxes ->\n let unfinalized_commitments, _ = extend state.unfinalized_commitments in\n let state =\n {\n state with\n uncommitted_inboxes;\n unfinalized_commitments;\n commitment_newest_hash = Some hash;\n }\n in\n if is_above_watermark state.commitments_watermark level then\n (* See {{Note inbox}} in [Tx_rollup_commitment_storage] for\n why it is safe to \226\128\156free\226\128\157 the inbox storage when it is\n committed too. *)\n adjust_storage_allocation state ~delta:(Z.neg Tx_rollup_inbox_repr.size)\n >>? fun (state, _) ->\n ok {state with commitments_watermark = make_watermark level}\n else ok state\n | None ->\n error (Internal_error \"Cannot create a commitment due to lack of inbox\")\n\nlet record_commitment_rejection state level predecessor_hash =\n let unwrap_option msg = function\n | Some x -> ok x\n | _ -> error (Internal_error msg)\n in\n let check_none msg = function\n | None -> ok ()\n | Some _ -> error (Internal_error msg)\n in\n left_extend state.uncommitted_inboxes level >>? fun uncommitted_inboxes ->\n let state = {state with uncommitted_inboxes} in\n right_cut state.unfinalized_commitments level\n >>? fun unfinalized_commitments ->\n match Tx_rollup_level_repr.pred level with\n | Some pred_level\n when belongs_to state.unfinalized_commitments pred_level\n || belongs_to state.finalized_commitments pred_level ->\n (* Case 1. Predecessor level of the rejected commitments has a commitment in the storage *)\n unwrap_option \"Missing predecessor commitment\" predecessor_hash\n >>? fun predecessor_hash ->\n ok\n {\n state with\n unfinalized_commitments;\n commitment_newest_hash = Some predecessor_hash;\n }\n | Some _ ->\n (* Case 2. Predecessor level of the rejected commitments has its\n commitment removed from the storage *)\n check_none \"Unexpected predecessor hash\" predecessor_hash >>? fun () ->\n unwrap_option\n \"Missing commitment hash\"\n state.last_removed_commitment_hashes\n >>? fun (_, pred_hash) ->\n ok\n {\n state with\n unfinalized_commitments;\n commitment_newest_hash = Some pred_hash;\n }\n | None ->\n (* Case 3. The rejected commitment is the commitment of the root level *)\n ok {state with unfinalized_commitments; commitment_newest_hash = None}\n\nlet record_commitment_deletion state level hash message_hash =\n match range_oldest state.finalized_commitments with\n | Some oldest when Tx_rollup_level_repr.(level = oldest) ->\n shrink state.finalized_commitments >>? fun finalized_commitments ->\n ok\n {\n state with\n finalized_commitments;\n last_removed_commitment_hashes = Some (message_hash, hash);\n }\n | _ -> error (Internal_error \"Trying to remove an incorrect commitment\")\n\nlet burn_cost ~limit state size =\n Tez_repr.(state.burn_per_byte *? Int64.of_int size) >>? fun burn ->\n match limit with\n | Some limit when Tez_repr.(limit >= burn) ->\n error (Submit_batch_burn_exceeded {burn; limit})\n | _ -> ok burn\n\nlet finalized_commitments_range state =\n match\n ( range_oldest state.finalized_commitments,\n range_newest state.finalized_commitments )\n with\n | Some oldest, Some newest -> Some (oldest, newest)\n | _ -> None\n\nlet check_level_can_be_rejected state level =\n match\n ( range_oldest state.unfinalized_commitments,\n range_newest state.unfinalized_commitments )\n with\n | Some oldest, Some newest ->\n error_unless Tx_rollup_level_repr.(oldest <= level && level <= newest)\n @@ Cannot_reject_level\n {provided = level; accepted_range = Some (oldest, newest)}\n | _ -> error @@ Cannot_reject_level {provided = level; accepted_range = None}\n\nlet last_removed_commitment_hashes state = state.last_removed_commitment_hashes\n\nlet head_levels state =\n match (state.uncommitted_inboxes, state.tezos_head_level) with\n | Empty {next = l}, Some tz_level ->\n Option.map (fun l -> (l, tz_level)) (Tx_rollup_level_repr.pred l)\n | Interval {newest; _}, Some tz_level -> Some (newest, tz_level)\n | _ -> None\n\nmodule Internal_for_tests = struct\n let make :\n ?burn_per_byte:Tez_repr.t ->\n ?inbox_ema:int ->\n ?last_removed_commitment_hashes:\n Tx_rollup_message_result_hash_repr.t * Tx_rollup_commitment_repr.Hash.t ->\n ?finalized_commitments:Tx_rollup_level_repr.t * Tx_rollup_level_repr.t ->\n ?unfinalized_commitments:Tx_rollup_level_repr.t * Tx_rollup_level_repr.t ->\n ?uncommitted_inboxes:Tx_rollup_level_repr.t * Tx_rollup_level_repr.t ->\n ?commitment_newest_hash:Tx_rollup_commitment_repr.Hash.t ->\n ?tezos_head_level:Raw_level_repr.t ->\n ?occupied_storage:Z.t ->\n ?commitments_watermark:Tx_rollup_level_repr.t ->\n allocated_storage:Z.t ->\n unit ->\n t =\n fun ?(burn_per_byte = Tez_repr.zero)\n ?(inbox_ema = 0)\n ?last_removed_commitment_hashes\n ?finalized_commitments\n ?unfinalized_commitments\n ?uncommitted_inboxes\n ?commitment_newest_hash\n ?tezos_head_level\n ?(occupied_storage = Z.zero)\n ?commitments_watermark\n ~allocated_storage\n () ->\n let to_range = function\n | Some (oldest, newest) ->\n assert (Tx_rollup_level_repr.(oldest <= newest)) ;\n Interval {oldest; newest}\n | _ -> Empty {next = Tx_rollup_level_repr.root}\n in\n\n let unfinalized_commitments = to_range unfinalized_commitments in\n let finalized_commitments = to_range finalized_commitments in\n let uncommitted_inboxes = to_range uncommitted_inboxes in\n\n {\n last_removed_commitment_hashes;\n burn_per_byte;\n occupied_storage;\n allocated_storage;\n inbox_ema;\n finalized_commitments;\n unfinalized_commitments;\n uncommitted_inboxes;\n commitment_newest_hash;\n tezos_head_level;\n commitments_watermark;\n }\n\n let get_inbox_ema : t -> int = fun {inbox_ema; _} -> inbox_ema\n\n let get_occupied_storage : t -> Z.t =\n fun {occupied_storage; _} -> occupied_storage\n\n let set_occupied_storage : Z.t -> t -> t =\n fun occupied_storage st -> {st with occupied_storage}\n\n let get_allocated_storage : t -> Z.t =\n fun {allocated_storage; _} -> allocated_storage\n\n let set_allocated_storage : Z.t -> t -> t =\n fun allocated_storage st -> {st with allocated_storage}\n\n let reset_commitments_watermark : t -> t =\n fun st -> {st with commitments_watermark = None}\n\n let get_commitments_watermark : t -> Tx_rollup_level_repr.t option =\n fun st -> st.commitments_watermark\nend\n" ;
} ;
{ name = "Dal_errors_repr" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Trili Tech <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error +=\n | Dal_feature_disabled\n | Dal_slot_index_above_hard_limit\n | Dal_attestation_unexpected_size of {expected : int; got : int}\n | Dal_publish_slot_header_future_level of {\n provided : Raw_level_repr.t;\n expected : Raw_level_repr.t;\n }\n | Dal_publish_slot_header_past_level of {\n provided : Raw_level_repr.t;\n expected : Raw_level_repr.t;\n }\n | Dal_publish_slot_header_invalid_index of {\n given : Dal_slot_repr.Index.t;\n maximum : Dal_slot_repr.Index.t;\n }\n | Dal_publish_slot_header_candidate_with_low_fees of {\n proposed_fees : Tez_repr.t;\n }\n | Dal_attestation_size_limit_exceeded of {maximum_size : int; got : int}\n | Dal_publish_slot_header_duplicate of {slot_header : Dal_slot_repr.Header.t}\n | Dal_publish_slot_header_invalid_proof of {\n slot_header : Dal_slot_repr.Header.operation;\n }\n | Dal_data_availibility_attestor_not_in_committee of {\n attestor : Signature.Public_key_hash.t;\n level : Level_repr.t;\n }\n | Dal_operation_for_old_level of {\n current : Raw_level_repr.t;\n given : Raw_level_repr.t;\n }\n | Dal_operation_for_future_level of {\n current : Raw_level_repr.t;\n given : Raw_level_repr.t;\n }\n\nlet () =\n let open Data_encoding in\n let description =\n \"Data-availability layer will be enabled in a future proposal.\"\n in\n register_error_kind\n `Permanent\n ~id:\"operation.dal_disabled\"\n ~title:\"DAL is disabled\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.unit\n (function Dal_feature_disabled -> Some () | _ -> None)\n (fun () -> Dal_feature_disabled) ;\n\n let description =\n \"The attestation for data availability has a different size\"\n in\n register_error_kind\n `Permanent\n ~id:\"dal_attestation_unexpected_size\"\n ~title:\"DAL attestation unexpected size\"\n ~description\n ~pp:(fun ppf (expected, got) ->\n Format.fprintf ppf \"%s: Expected %d. Got %d.\" description expected got)\n (obj2 (req \"expected_size\" int31) (req \"got\" int31))\n (function\n | Dal_attestation_unexpected_size {expected; got} -> Some (expected, got)\n | _ -> None)\n (fun (expected, got) -> Dal_attestation_unexpected_size {expected; got}) ;\n let description = \"Slot index above hard limit\" in\n register_error_kind\n `Permanent\n ~id:\"dal_slot_index_negative_orabove_hard_limit\"\n ~title:\"DAL slot index negative or above hard limit\"\n ~description\n ~pp:(fun ppf () ->\n Format.fprintf\n ppf\n \"%s: Maximum allowed %a.\"\n description\n Dal_slot_repr.Index.pp\n Dal_slot_repr.Index.max_value)\n Data_encoding.unit\n (function Dal_slot_index_above_hard_limit -> Some () | _ -> None)\n (fun () -> Dal_slot_index_above_hard_limit) ;\n let description = \"Unexpected level in the future in slot header\" in\n register_error_kind\n `Temporary\n ~id:\"dal_publish_slot_header_future_level\"\n ~title:\"DAL slot header future level\"\n ~description\n ~pp:(fun ppf (provided, expected) ->\n Format.fprintf\n ppf\n \"%s: Provided %a. Expected %a.\"\n description\n Raw_level_repr.pp\n provided\n Raw_level_repr.pp\n expected)\n (obj2\n (req \"provided\" Raw_level_repr.encoding)\n (req \"got\" Raw_level_repr.encoding))\n (function\n | Dal_publish_slot_header_future_level {provided; expected} ->\n Some (provided, expected)\n | _ -> None)\n (fun (provided, expected) ->\n Dal_publish_slot_header_future_level {provided; expected}) ;\n let description = \"Unexpected level in the past in slot header\" in\n register_error_kind\n `Branch\n ~id:\"dal_publish_slot_header_past_level\"\n ~title:\"DAL slot header past level\"\n ~description\n ~pp:(fun ppf (provided, expected) ->\n Format.fprintf\n ppf\n \"%s: Provided %a. Expected %a.\"\n description\n Raw_level_repr.pp\n provided\n Raw_level_repr.pp\n expected)\n (obj2\n (req \"provided\" Raw_level_repr.encoding)\n (req \"got\" Raw_level_repr.encoding))\n (function\n | Dal_publish_slot_header_past_level {provided; expected} ->\n Some (provided, expected)\n | _ -> None)\n (fun (provided, expected) ->\n Dal_publish_slot_header_past_level {provided; expected}) ;\n let description = \"Bad index for slot header\" in\n register_error_kind\n `Permanent\n ~id:\"dal_publish_slot_header_invalid_index\"\n ~title:\"DAL slot header invalid index\"\n ~description\n ~pp:(fun ppf (given, maximum) ->\n Format.fprintf\n ppf\n \"%s: Given %a. Maximum %a.\"\n description\n Dal_slot_repr.Index.pp\n given\n Dal_slot_repr.Index.pp\n maximum)\n (obj2\n (req \"given\" Dal_slot_repr.Index.encoding)\n (req \"got\" Dal_slot_repr.Index.encoding))\n (function\n | Dal_publish_slot_header_invalid_index {given; maximum} ->\n Some (given, maximum)\n | _ -> None)\n (fun (given, maximum) ->\n Dal_publish_slot_header_invalid_index {given; maximum}) ;\n (* DAL/FIXME https://gitlab.com/tezos/tezos/-/issues/3114\n Better error message *)\n let description = \"Slot header with too low fees\" in\n register_error_kind\n `Permanent\n ~id:\"dal_publish_slot_header_with_low_fees\"\n ~title:\"DAL slot header with low fees\"\n ~description\n ~pp:(fun ppf proposed ->\n Format.fprintf\n ppf\n \"%s: Proposed fees %a.\"\n description\n Tez_repr.pp\n proposed)\n (obj1 (req \"proposed\" Tez_repr.encoding))\n (function\n | Dal_publish_slot_header_candidate_with_low_fees {proposed_fees} ->\n Some proposed_fees\n | _ -> None)\n (fun proposed_fees ->\n Dal_publish_slot_header_candidate_with_low_fees {proposed_fees}) ;\n let description = \"The attestation for data availability is a too big\" in\n register_error_kind\n `Permanent\n ~id:\"dal_attestation_size_limit_exceeded\"\n ~title:\"DAL attestation exceeded the limit\"\n ~description\n ~pp:(fun ppf (maximum_size, got) ->\n Format.fprintf\n ppf\n \"%s: Maximum is %d. Got %d.\"\n description\n maximum_size\n got)\n (obj2 (req \"maximum_size\" int31) (req \"got\" int31))\n (function\n | Dal_attestation_size_limit_exceeded {maximum_size; got} ->\n Some (maximum_size, got)\n | _ -> None)\n (fun (maximum_size, got) ->\n Dal_attestation_size_limit_exceeded {maximum_size; got}) ;\n (* DAL/FIXME https://gitlab.com/tezos/tezos/-/issues/3114\n Better error message. *)\n let description = \"A slot header for this slot was already proposed\" in\n register_error_kind\n `Permanent\n ~id:\"dal_publish_slot_heade_duplicate\"\n ~title:\"DAL publish slot header duplicate\"\n ~description\n ~pp:(fun ppf _proposed -> Format.fprintf ppf \"%s\" description)\n (obj1 (req \"proposed\" Dal_slot_repr.Header.encoding))\n (function\n | Dal_publish_slot_header_duplicate {slot_header} -> Some slot_header\n | _ -> None)\n (fun slot_header -> Dal_publish_slot_header_duplicate {slot_header}) ;\n let description = \"The slot header's commitment proof does not check\" in\n register_error_kind\n `Permanent\n ~id:\"dal_publish_slot_header_invalid_proof\"\n ~title:\"DAL publish slot header invalid proof\"\n ~description\n ~pp:(fun ppf _proposed -> Format.fprintf ppf \"%s\" description)\n Dal_slot_repr.Header.operation_encoding\n (function\n | Dal_publish_slot_header_invalid_proof {slot_header} -> Some slot_header\n | _ -> None)\n (fun slot_header -> Dal_publish_slot_header_invalid_proof {slot_header}) ;\n register_error_kind\n `Outdated\n ~id:\"Dal_operation_for_old_level\"\n ~title:\"Dal operation for an old level\"\n ~description:\"The Dal operation targets an old level\"\n ~pp:(fun ppf (current_lvl, given_lvl) ->\n Format.fprintf\n ppf\n \"Dal operation targets an old level %a. Current level is %a.\"\n Raw_level_repr.pp\n given_lvl\n Raw_level_repr.pp\n current_lvl)\n Data_encoding.(\n obj2\n (req \"current_level\" Raw_level_repr.encoding)\n (req \"given_level\" Raw_level_repr.encoding))\n (function\n | Dal_operation_for_old_level {current; given} -> Some (current, given)\n | _ -> None)\n (fun (current, given) -> Dal_operation_for_old_level {current; given}) ;\n register_error_kind\n `Temporary\n ~id:\"Dal_operation_for_future_level\"\n ~title:\"Dal operation for a future level\"\n ~description:\"The Dal operation target a future level\"\n ~pp:(fun ppf (current_lvl, given_lvl) ->\n Format.fprintf\n ppf\n \"Dal operation targets a future level %a. Current level is %a.\"\n Raw_level_repr.pp\n given_lvl\n Raw_level_repr.pp\n current_lvl)\n Data_encoding.(\n obj2\n (req \"current_level\" Raw_level_repr.encoding)\n (req \"given_level\" Raw_level_repr.encoding))\n (function\n | Dal_operation_for_future_level {current; given} -> Some (current, given)\n | _ -> None)\n (fun (current, given) -> Dal_operation_for_future_level {current; given}) ;\n register_error_kind\n `Permanent\n ~id:\"Dal_data_availibility_attestor_not_in_committee\"\n ~title:\"The attestor is not part of the DAL committee for this level\"\n ~description:\"The attestor is not part of the DAL committee for this level\"\n ~pp:(fun ppf (attestor, level) ->\n Format.fprintf\n ppf\n \"The attestor %a is not part of the DAL committee for the level %a\"\n Signature.Public_key_hash.pp\n attestor\n Level_repr.pp\n level)\n Data_encoding.(\n obj2\n (req \"attestor\" Signature.Public_key_hash.encoding)\n (req \"level\" Level_repr.encoding))\n (function\n | Dal_data_availibility_attestor_not_in_committee {attestor; level} ->\n Some (attestor, level)\n | _ -> None)\n (fun (attestor, level) ->\n Dal_data_availibility_attestor_not_in_committee {attestor; level})\n" ;
} ;
{ name = "Zk_rollup_scalar" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Representation of scalars used by the ZK Rollup alongside\n manipulation functions *)\n\n(** Scalars are transparently BLS12-381 scalars *)\ntype t = Bls.Primitive.Fr.t\n\n(** Safe conversion from Z.t.\n If the numerical value is not in the field, modulo reduction\n is applied. *)\nval of_z : Z.t -> t\n\n(** Safe conversion from bits, represented as a string.\n If the numerical value is not in the field, modulo reduction\n is applied. *)\nval of_bits : string -> t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t = Bls.Primitive.Fr.t\n\nlet of_z z =\n (* In case [z] is outside of the field, i.e. Z >= Fr.order,\n [Bls.Primitive.Fr.of_z] will apply a modulo reduction to ge\n t a field element *)\n Bls.Primitive.Fr.of_z z\n\nlet of_bits bs =\n (* The bits are interpreted as a Z integer *)\n let z = Z.of_bits bs in\n of_z z\n" ;
} ;
{ name = "Zk_rollup_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** A ZK rollup has an address starting with \"epx1\".\n ZKRU addresses have a length of 20 bytes, which means\n that they have an injective encoding as BLS12-381 scalars.\n*)\nmodule Address : sig\n include S.HASH\n\n (** [from_nonce nonce] produces an address completely determined by\n an operation hash and an origination counter. *)\n val from_nonce : Origination_nonce.t -> t tzresult\n\n (** [encoded_size] is the number of bytes needed to represent an address. *)\n val encoded_size : int\n\n val of_b58data : Base58.data -> t option\n\n val prefix : string\nend\n\ntype t = Address.t\n\n(** [to_scalar address] returns the scalar corresponding to [address] *)\nval to_scalar : t -> Zk_rollup_scalar.t\n\n(** Description of a ZK rollup's pending list. *)\ntype pending_list =\n | Empty of {next_index : int64}\n (** Empty pending list but starting point will be [next_index]\n when adding to the list *)\n | Pending of {next_index : int64; length : int}\n (** Pending list with\n [(next_index - length) .. (next_index - 1)].\n [length] is encoded as a [uint16]. *)\n\nval pending_list_encoding : pending_list Data_encoding.t\n\nmodule Index : Storage_description.INDEX with type t = t\n\n(** [in_memory_size zk_rollup] returns the number of bytes a [zk_rollup]\n address uses in RAM. *)\nval in_memory_size : t -> Cache_memory_helpers.sint\n\nmodule Internal_for_tests : sig\n val originated_zk_rollup : Origination_nonce.t -> Address.t\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule Address = struct\n let prefix = \"epx1\"\n\n let encoded_size = 37\n\n let decoded_prefix = \"\\001\\023\\224\\125\"\n\n module H =\n Blake2B.Make\n (Base58)\n (struct\n let name = \"Zk_rollup_hash\"\n\n let title = \"A zk rollup address\"\n\n let b58check_prefix = decoded_prefix\n\n let size = Some 20\n end)\n\n include H\n\n let () = Base58.check_encoded_prefix b58check_encoding prefix encoded_size\n\n include Path_encoding.Make_hex (H)\n\n type error += (* `Permanent *) Error_zk_rollup_address_generation\n\n let () =\n let open Data_encoding in\n let msg = \"Error while generating rollup address\" in\n register_error_kind\n `Permanent\n ~id:\"rollup.error_zk_rollup_address_generation\"\n ~title:msg\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" msg)\n ~description:msg\n unit\n (function Error_zk_rollup_address_generation -> Some () | _ -> None)\n (fun () -> Error_zk_rollup_address_generation)\n\n let from_nonce nonce =\n Data_encoding.Binary.to_bytes_opt Origination_nonce.encoding nonce\n |> function\n | None -> error Error_zk_rollup_address_generation\n | Some nonce -> ok @@ hash_bytes [nonce]\n\n let of_b58data = function H.Data h -> Some h | _ -> None\nend\n\ntype t = Address.t\n\nlet to_scalar x =\n Zk_rollup_scalar.of_bits\n (Data_encoding.Binary.to_string_exn Address.encoding x)\n\ntype pending_list =\n | Empty of {next_index : int64}\n | Pending of {next_index : int64; length : int}\n\nlet pending_list_encoding : pending_list Data_encoding.t =\n let open Data_encoding in\n let empty_tag, pending_tag = (0, 1) in\n let empty_encoding =\n obj1 (req \"next_index\" Compact.(make ~tag_size:`Uint8 int64))\n in\n let pending_encoding =\n obj2\n (req \"next_index\" Compact.(make ~tag_size:`Uint8 int64))\n (req \"length\" uint16)\n in\n matching\n (function\n | Empty {next_index} -> matched empty_tag empty_encoding next_index\n | Pending {next_index; length} ->\n matched pending_tag pending_encoding (next_index, length))\n [\n case\n ~title:\"Empty\"\n (Tag empty_tag)\n empty_encoding\n (function Empty {next_index} -> Some next_index | _ -> None)\n (fun next_index -> Empty {next_index});\n case\n ~title:\"Pending\"\n (Tag pending_tag)\n pending_encoding\n (function\n | Pending {next_index; length} -> Some (next_index, length)\n | _ -> None)\n (fun (next_index, length) -> Pending {next_index; length});\n ]\n\nmodule Index = struct\n type nonrec t = t\n\n let path_length = 1\n\n let to_path c l =\n let raw_key = Data_encoding.Binary.to_bytes_exn Address.encoding c in\n let (`Hex key) = Hex.of_bytes raw_key in\n key :: l\n\n let of_path = function\n | [key] ->\n Option.bind\n (Hex.to_bytes (`Hex key))\n (Data_encoding.Binary.of_bytes_opt Address.encoding)\n | _ -> None\n\n let rpc_arg = Address.rpc_arg\n\n let encoding = Address.encoding\n\n let compare = Address.compare\nend\n\nlet in_memory_size (_ : t) =\n let open Cache_memory_helpers in\n h1w +! string_size_gen Address.size\n\nmodule Internal_for_tests = struct\n let originated_zk_rollup nonce =\n let data =\n Data_encoding.Binary.to_bytes_exn Origination_nonce.encoding nonce\n in\n Address.hash_bytes [data]\nend\n" ;
} ;
{ name = "Zk_rollup_state_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** The state of a ZK Rollup is an opaque array of scalars, and represents\n the L1's view of the L2 state.\n Although the length of this array is unbound, this type should describe\n a succinct representation of the entire RU state. Upon origination, the\n length of a ZKRU's state is fixed.\n*)\ntype t = Zk_rollup_scalar.t array\n\nval encoding : t Data_encoding.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t = Zk_rollup_scalar.t array\n\nlet encoding = Plonk.scalar_array_encoding\n" ;
} ;
{ name = "Zk_rollup_account_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule SMap : Map.S with type key = string\n\n(** Representation of a ZK Rollup account. *)\n\n(** Static part of a ZKRU account. These are set at origination,\n after which they cannot be modified. *)\ntype static = {\n public_parameters : Plonk.public_parameters;\n (** Input to the Plonk verifier that are fixed once the circuits\n are decided. *)\n state_length : int; (** Number of scalars in the state. *)\n circuits_info : [`Public | `Private | `Fee] SMap.t;\n (** Circuit names, alongside a tag indicating its kind. *)\n nb_ops : int; (** Valid op codes of L2 operations must be in \\[0, nb_ops) *)\n}\n\n(** Dynamic part of a ZKRU account. *)\ntype dynamic = {\n state : Zk_rollup_state_repr.t;\n (** Array of scalars representing the state of the rollup\n at a given level. *)\n paid_l2_operations_storage_space : Z.t;\n (** Number of bytes for storage of L2 operations that have\n been already paid for. *)\n used_l2_operations_storage_space : Z.t;\n (** Number of bytes for storage of L2 operations that are\n being used. *)\n}\n\ntype t = {static : static; dynamic : dynamic}\n\nval encoding : t Data_encoding.t\n\n(* Encoding for the [circuits_info] field.\n Checks that keys are not duplicated in serialized representation. *)\nval circuits_info_encoding : [`Public | `Private | `Fee] SMap.t Data_encoding.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule SMap = Map.Make (String)\n\ntype static = {\n public_parameters : Plonk.public_parameters;\n state_length : int;\n circuits_info : [`Public | `Private | `Fee] SMap.t;\n nb_ops : int;\n}\n\ntype dynamic = {\n state : Zk_rollup_state_repr.t;\n paid_l2_operations_storage_space : Z.t;\n used_l2_operations_storage_space : Z.t;\n}\n\ntype t = {static : static; dynamic : dynamic}\n\nlet circuits_info_encoding : [`Public | `Private | `Fee] SMap.t Data_encoding.t\n =\n let open Data_encoding in\n let variant_encoding =\n let public_tag, public_encoding = (0, obj1 @@ req \"public\" unit) in\n let private_tag, private_encoding = (1, obj1 @@ req \"private\" unit) in\n let fee_tag, fee_encoding = (2, obj1 @@ req \"fee\" unit) in\n matching\n (function\n | `Public -> matched public_tag public_encoding ()\n | `Private -> matched private_tag private_encoding ()\n | `Fee -> matched fee_tag fee_encoding ())\n [\n case\n ~title:\"Public\"\n (Tag public_tag)\n public_encoding\n (function `Public -> Some () | _ -> None)\n (fun () -> `Public);\n case\n ~title:\"Private\"\n (Tag private_tag)\n private_encoding\n (function `Private -> Some () | _ -> None)\n (fun () -> `Private);\n case\n ~title:\"Fee\"\n (Tag fee_tag)\n fee_encoding\n (function `Fee -> Some () | _ -> None)\n (fun () -> `Fee);\n ]\n in\n conv_with_guard\n (fun m -> List.of_seq @@ SMap.to_seq m)\n (fun l ->\n let m = SMap.of_seq @@ List.to_seq l in\n if\n (* Check that the list has no duplicated keys *)\n Compare.List_length_with.(l <> SMap.cardinal m)\n then Error \"Zk_rollup_origination: circuits_info has duplicated keys\"\n else Ok m)\n (list (tup2 (string Plain) variant_encoding))\n\nlet encoding =\n let open Data_encoding in\n let static_encoding =\n conv\n (fun {public_parameters; state_length; circuits_info; nb_ops} ->\n (public_parameters, state_length, circuits_info, nb_ops))\n (fun (public_parameters, state_length, circuits_info, nb_ops) ->\n {public_parameters; state_length; circuits_info; nb_ops})\n (obj4\n (req \"public_parameters\" Plonk.public_parameters_encoding)\n (req \"state_length\" int31)\n (req \"circuits_info\" circuits_info_encoding)\n (req \"nb_ops\" int31))\n in\n let dynamic_encoding =\n conv\n (fun {\n state;\n paid_l2_operations_storage_space;\n used_l2_operations_storage_space;\n } ->\n ( state,\n paid_l2_operations_storage_space,\n used_l2_operations_storage_space ))\n (fun ( state,\n paid_l2_operations_storage_space,\n used_l2_operations_storage_space ) ->\n {\n state;\n paid_l2_operations_storage_space;\n used_l2_operations_storage_space;\n })\n (obj3\n (req \"state\" Zk_rollup_state_repr.encoding)\n (req \"paid_l2_operations_storage_space\" n)\n (req \"used_l2_operations_storage_space\" n))\n in\n conv\n (fun {static; dynamic} -> (static, dynamic))\n (fun (static, dynamic) -> {static; dynamic})\n (obj2 (req \"static\" static_encoding) (req \"dynamic\" dynamic_encoding))\n" ;
} ;
{ name = "Zk_rollup_ticket_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Representation of tickets for the ZKRU.\n This data is used by the [Zk_rollup_publish] operation to compute the\n ticket hashes needed to transfer tickets from the ZK Rollup to an\n implicit account.\n*)\ntype t = {\n contents : Script_repr.expr;\n ty : Script_repr.expr;\n ticketer : Contract_repr.t;\n}\n\nval encoding : t Data_encoding.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t = {\n contents : Script_repr.expr;\n ty : Script_repr.expr;\n ticketer : Contract_repr.t;\n}\n\nlet encoding : t Data_encoding.t =\n let open Data_encoding in\n conv\n (fun {contents; ty; ticketer} -> (contents, ty, ticketer))\n (fun (contents, ty, ticketer) -> {contents; ty; ticketer})\n (obj3\n (req \"contents\" Script_repr.expr_encoding)\n (req \"ty\" Script_repr.expr_encoding)\n (req \"ticketer\" Contract_repr.encoding))\n" ;
} ;
{ name = "Zk_rollup_operation_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** The [price] of an L2 operation represents the net ticket\n transfer from L1 to L2 that it will produce.\n [id] is a ticket hash used as a ticket identifier and [amount]\n is positive if the operation transfers tickets from L1 to L2,\n negative if it does so from L2 to L1, and zero when no transfer\n is done between layers.\n*)\ntype price = {id : Ticket_hash_repr.t; amount : Z.t}\n\n(** A ZK rollup L2 operation has two parts: a transparent header and\n an opaque payload.\n The header is made up by:\n {ul\n {li An [op_code] in the range \\[0, nb_ops)}\n {li The [price] of this L2 operation}\n {li [l1_dst] is the public key hash of the implicit account that will\n be credited with the withdrawal generated by this operation, if any}\n {li [rollup_id] is the address of the rollup this operation targets}\n }\n\n This type represents the L1's view of L2 operations. It's important\n to remember that this is only used for public operations, as the\n protocol isn't aware of private ones.\n*)\ntype t = {\n op_code : int;\n price : price;\n l1_dst : Signature.Public_key_hash.t;\n rollup_id : Zk_rollup_repr.t;\n payload : Zk_rollup_scalar.t array;\n}\n\nval encoding : t Data_encoding.t\n\n(** Special encoding needed to feed L2 operations to the Plonk verifier *)\nval to_scalar_array : t -> Zk_rollup_scalar.t array\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype price = {id : Ticket_hash_repr.t; amount : Z.t}\n\ntype t = {\n op_code : int;\n price : price;\n l1_dst : Signature.Public_key_hash.t;\n rollup_id : Zk_rollup_repr.t;\n payload : Zk_rollup_scalar.t array;\n}\n\nlet int_to_scalar x = Zk_rollup_scalar.of_z (Z.of_int x)\n\nlet pkh_to_scalar x =\n Zk_rollup_scalar.of_bits\n (Data_encoding.Binary.to_string_exn Signature.Public_key_hash.encoding x)\n\nlet ticket_hash_to_scalar ticket_hash =\n Zk_rollup_scalar.of_bits\n @@ Data_encoding.Binary.to_string_exn Ticket_hash_repr.encoding ticket_hash\n\nlet to_scalar_array {op_code; price; l1_dst; rollup_id; payload} =\n Array.concat\n [\n [|\n int_to_scalar op_code;\n ticket_hash_to_scalar price.id;\n Zk_rollup_scalar.of_z @@ Z.abs price.amount;\n pkh_to_scalar l1_dst;\n Zk_rollup_repr.to_scalar rollup_id;\n |];\n payload;\n ]\n\nlet price_encoding =\n Data_encoding.(\n conv\n (fun {id; amount} -> (id, amount))\n (fun (id, amount) -> {id; amount})\n (obj2 (req \"id\" Ticket_hash_repr.encoding) (req \"amount\" z)))\n\nlet encoding =\n Data_encoding.(\n conv\n (fun {op_code; price; l1_dst; rollup_id; payload} ->\n (op_code, price, l1_dst, rollup_id, payload))\n (fun (op_code, price, l1_dst, rollup_id, payload) ->\n {op_code; price; l1_dst; rollup_id; payload})\n (obj5\n (req \"op_code\" int31)\n (req \"price\" price_encoding)\n (req \"l1_dst\" Signature.Public_key_hash.encoding)\n (req \"rollup_id\" Zk_rollup_repr.Address.encoding)\n (req \"payload\" Plonk.scalar_array_encoding)))\n" ;
} ;
{ name = "Zk_rollup_update_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Payload of a ZK Rollup update operation.\n The operator only needs to send a subset of the public inputs\n defined in {!Zk_rollup_circuit_public_inputs_repr}, the rest\n is provided by the protocol.\n*)\n\n(** Minimal subset of public inputs for the public L2 operations' circuits. *)\ntype op_pi = {\n new_state : Zk_rollup_state_repr.t;\n fee : Zk_rollup_scalar.t;\n exit_validity : bool;\n}\n\n(** Minimal subset of public inputs for the circuits for batches of\n private L2 operations *)\ntype private_inner_pi = {\n new_state : Zk_rollup_state_repr.t;\n fees : Zk_rollup_scalar.t;\n}\n\n(** Minimal subset of public inputs for the \"fee\" circuit. *)\ntype fee_pi = {new_state : Zk_rollup_state_repr.t}\n\n(** Payload of an update operation.\n Includes the proof and the public inputs that are needed to verify it.\n Each set of public inputs also carries the string that identifies the\n circuit which they are for. *)\ntype t = {\n pending_pis : (string * op_pi) list;\n private_pis : (string * private_inner_pi) list;\n fee_pi : fee_pi;\n proof : Plonk.proof;\n}\n\nval encoding : t Data_encoding.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype op_pi = {\n new_state : Zk_rollup_state_repr.t;\n fee : Zk_rollup_scalar.t;\n exit_validity : bool;\n}\n\ntype private_inner_pi = {\n new_state : Zk_rollup_state_repr.t;\n fees : Zk_rollup_scalar.t;\n}\n\ntype fee_pi = {new_state : Zk_rollup_state_repr.t}\n\n(* Data sent to an update operation *)\ntype t = {\n pending_pis : (string * op_pi) list;\n private_pis : (string * private_inner_pi) list;\n fee_pi : fee_pi;\n proof : Plonk.proof;\n}\n\nlet op_pi_encoding : op_pi Data_encoding.t =\n Data_encoding.(\n conv\n (fun {new_state; fee; exit_validity} -> (new_state, fee, exit_validity))\n (fun (new_state, fee, exit_validity) -> {new_state; fee; exit_validity})\n (obj3\n (req \"new_state\" Zk_rollup_state_repr.encoding)\n (req \"fee\" Plonk.scalar_encoding)\n (req \"exit_validity\" bool)))\n\nlet private_inner_pi_encoding : private_inner_pi Data_encoding.t =\n Data_encoding.(\n conv\n (fun ({new_state; fees} : private_inner_pi) -> (new_state, fees))\n (fun (new_state, fees) -> {new_state; fees})\n (obj2\n (req \"new_state\" Zk_rollup_state_repr.encoding)\n (req \"fee\" Plonk.scalar_encoding)))\n\nlet fee_pi_encoding : fee_pi Data_encoding.t =\n Data_encoding.(\n conv\n (fun {new_state} -> new_state)\n (fun new_state -> {new_state})\n (obj1 (req \"new_state\" Zk_rollup_state_repr.encoding)))\n\nlet encoding : t Data_encoding.t =\n Data_encoding.(\n conv\n (fun {pending_pis; private_pis; fee_pi; proof} ->\n (pending_pis, private_pis, fee_pi, proof))\n (fun (pending_pis, private_pis, fee_pi, proof) ->\n {pending_pis; private_pis; fee_pi; proof})\n (obj4\n (req \"pending_pis\" (list @@ tup2 (string Plain) op_pi_encoding))\n (req\n \"private_pis\"\n (list @@ tup2 (string Plain) private_inner_pi_encoding))\n (req \"fee_pi\" fee_pi_encoding)\n (req \"proof\" Plonk.proof_encoding)))\n" ;
} ;
{ name = "Zk_rollup_circuit_public_inputs_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(**\n Abstraction layer for the public inputs to the ZKRU aPlonk circuits.\n\n As explained in the documentation, circuits in ZKRUs will be grouped into\n three categories: pending (public) operations, private batches and\n fee circuit. Each of these expects a different set of public inputs.\n*)\n\n(** Public inputs expected by circuits that handle single public\n L2 operations. *)\ntype pending_op_public_inputs = {\n old_state : Zk_rollup_state_repr.t;\n new_state : Zk_rollup_state_repr.t;\n fee : Zk_rollup_scalar.t;\n exit_validity : bool;\n zk_rollup : Zk_rollup_repr.t;\n l2_op : Zk_rollup_operation_repr.t;\n}\n\n(** Public inputs expected by circuits that handle a batch of private\n L2 operations. *)\ntype private_batch_public_inputs = {\n old_state : Zk_rollup_state_repr.t;\n new_state : Zk_rollup_state_repr.t;\n fees : Zk_rollup_scalar.t;\n zk_rollup : Zk_rollup_repr.t;\n}\n\n(** Public inputs expected by the circuit that handles the L2 fees. *)\ntype fee_public_inputs = {\n old_state : Zk_rollup_state_repr.t;\n new_state : Zk_rollup_state_repr.t;\n fees : Zk_rollup_scalar.t;\n}\n\ntype t =\n | Pending_op of pending_op_public_inputs\n | Private_batch of private_batch_public_inputs\n | Fee of fee_public_inputs\n\n(** Conversion to the type the aPlonk verifier expects. *)\nval to_scalar_array : t -> Zk_rollup_scalar.t array\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype pending_op_public_inputs = {\n old_state : Zk_rollup_state_repr.t;\n new_state : Zk_rollup_state_repr.t;\n fee : Zk_rollup_scalar.t;\n exit_validity : bool;\n zk_rollup : Zk_rollup_repr.t;\n l2_op : Zk_rollup_operation_repr.t;\n}\n\ntype private_batch_public_inputs = {\n old_state : Zk_rollup_state_repr.t;\n new_state : Zk_rollup_state_repr.t;\n fees : Zk_rollup_scalar.t;\n zk_rollup : Zk_rollup_repr.t;\n}\n\ntype fee_public_inputs = {\n old_state : Zk_rollup_state_repr.t;\n new_state : Zk_rollup_state_repr.t;\n fees : Zk_rollup_scalar.t;\n}\n\ntype t =\n | Pending_op of pending_op_public_inputs\n | Private_batch of private_batch_public_inputs\n | Fee of fee_public_inputs\n\nlet bool_to_scalar b =\n if b then Zk_rollup_scalar.of_z Z.one else Zk_rollup_scalar.of_z Z.zero\n\nlet to_scalar_array = function\n | Pending_op {old_state; new_state; fee; exit_validity; zk_rollup; l2_op} ->\n Array.concat\n [\n old_state;\n new_state;\n [|\n fee;\n bool_to_scalar exit_validity;\n Zk_rollup_repr.to_scalar zk_rollup;\n |];\n Zk_rollup_operation_repr.to_scalar_array l2_op;\n ]\n | Private_batch {old_state; new_state; fees; zk_rollup} ->\n Array.concat\n [old_state; new_state; [|fees; Zk_rollup_repr.to_scalar zk_rollup|]]\n | Fee {old_state; new_state; fees} ->\n Array.concat [old_state; new_state; [|fees|]]\n" ;
} ;
{ name = "Bond_id_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module defines identifiers for frozen bonds. *)\n\ntype t =\n | Tx_rollup_bond_id of Tx_rollup_repr.t\n | Sc_rollup_bond_id of Sc_rollup_repr.t\n\nval pp : Format.formatter -> t -> unit\n\nval encoding : t Data_encoding.t\n\ninclude Compare.S with type t := t\n\nmodule Internal_for_test : sig\n val destruct : string -> (t, string) result\n\n val construct : t -> string\nend\n\nmodule Index : Storage_description.INDEX with type t = t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t =\n | Tx_rollup_bond_id of Tx_rollup_repr.t\n | Sc_rollup_bond_id of Sc_rollup_repr.t\n\ninclude Compare.Make (struct\n type nonrec t = t\n\n let compare id1 id2 =\n match (id1, id2) with\n | Tx_rollup_bond_id id1, Tx_rollup_bond_id id2 ->\n Tx_rollup_repr.compare id1 id2\n | Sc_rollup_bond_id id1, Sc_rollup_bond_id id2 ->\n Sc_rollup_repr.Address.compare id1 id2\n | Tx_rollup_bond_id _, Sc_rollup_bond_id _ -> -1\n | Sc_rollup_bond_id _, Tx_rollup_bond_id _ -> 1\nend)\n\nlet encoding =\n let open Data_encoding in\n def \"bond_id\"\n @@ union\n [\n case\n (Tag 0)\n ~title:\"Tx_rollup_bond_id\"\n (obj1 (req \"tx_rollup\" Tx_rollup_repr.encoding))\n (function Tx_rollup_bond_id id -> Some id | _ -> None)\n (fun id -> Tx_rollup_bond_id id);\n case\n (Tag 1)\n ~title:\"Smart_rollup_bond_id\"\n (obj1 (req \"smart_rollup\" Sc_rollup_repr.encoding))\n (function Sc_rollup_bond_id id -> Some id | _ -> None)\n (fun id -> Sc_rollup_bond_id id);\n ]\n\nlet pp ppf = function\n | Tx_rollup_bond_id id -> Tx_rollup_repr.pp ppf id\n | Sc_rollup_bond_id id -> Sc_rollup_repr.pp ppf id\n\nlet destruct id =\n (* String.starts_with from the stdlib 4.14, with [unsafe_get] replaced by\n [get], comparators replaced by their versions in [Compare.*]. *)\n let starts_with ~prefix s =\n let open String in\n let len_s = length s and len_pre = length prefix in\n let rec aux i =\n if Compare.Int.(i = len_pre) then true\n else if Compare.Char.(get s i <> get prefix i) then false\n else aux (i + 1)\n in\n Compare.Int.(len_s >= len_pre) && aux 0\n in\n if starts_with ~prefix:Tx_rollup_prefixes.rollup_address.prefix id then\n match Tx_rollup_repr.of_b58check_opt id with\n | Some id -> Result.ok (Tx_rollup_bond_id id)\n | None -> Result.error \"Cannot parse transaction rollup id\"\n else if starts_with ~prefix:Sc_rollup_repr.Address.prefix id then\n match Sc_rollup_repr.Address.of_b58check_opt id with\n | Some id -> Result.ok (Sc_rollup_bond_id id)\n | None -> Result.error \"Cannot parse smart rollup id\"\n else Result.error \"Cannot parse rollup id\"\n\nlet construct = function\n | Tx_rollup_bond_id id -> Tx_rollup_repr.to_b58check id\n | Sc_rollup_bond_id id -> Sc_rollup_repr.Address.to_b58check id\n\nlet rpc_arg =\n RPC_arg.make\n ~descr:\"A bond identifier.\"\n ~name:\"bond_id\"\n ~construct\n ~destruct\n ()\n\nmodule Internal_for_test = struct\n let destruct = destruct\n\n let construct = construct\nend\n\nmodule Index = struct\n type nonrec t = t\n\n let path_length = 1\n\n let to_path c l =\n let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in\n let (`Hex key) = Hex.of_bytes raw_key in\n key :: l\n\n let of_path = function\n | [key] ->\n Option.bind\n (Hex.to_bytes (`Hex key))\n (Data_encoding.Binary.of_bytes_opt encoding)\n | _ -> None\n\n let rpc_arg = rpc_arg\n\n let encoding = encoding\n\n let compare = compare\nend\n" ;
} ;
{ name = "Vote_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** a protocol change proposal *)\ntype proposal = Protocol_hash.t\n\n(** votes can be for, against or neutral.\n Neutral serves to count towards a quorum *)\ntype ballot = Yay | Nay | Pass\n\nval ballot_encoding : ballot Data_encoding.t\n\nval equal_ballot : ballot -> ballot -> bool\n\nval pp_ballot : Format.formatter -> ballot -> unit\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype proposal = Protocol_hash.t\n\ntype ballot = Yay | Nay | Pass\n\nlet ballot_encoding =\n let of_int8 = function\n | 0 -> Ok Yay\n | 1 -> Ok Nay\n | 2 -> Ok Pass\n | _ -> Error \"ballot_of_int8\"\n in\n let to_int8 = function Yay -> 0 | Nay -> 1 | Pass -> 2 in\n let open Data_encoding in\n (* union *)\n splitted\n ~binary:(conv_with_guard to_int8 of_int8 int8)\n ~json:(string_enum [(\"yay\", Yay); (\"nay\", Nay); (\"pass\", Pass)])\n\nlet equal_ballot a b =\n match (a, b) with Yay, Yay | Nay, Nay | Pass, Pass -> true | _ -> false\n\nlet pp_ballot ppf = function\n | Yay -> Format.fprintf ppf \"yay\"\n | Nay -> Format.fprintf ppf \"nay\"\n | Pass -> Format.fprintf ppf \"pass\"\n" ;
} ;
{ name = "Liquidity_baking_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Tocqueville Group, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Options available for the Liquidity Baking per-block vote *)\n\ntype liquidity_baking_toggle_vote = LB_on | LB_off | LB_pass\n\nval liquidity_baking_toggle_vote_encoding :\n liquidity_baking_toggle_vote Data_encoding.encoding\n\n(** Exponential moving average of toggle votes. Represented as an int32 between\n 0 and 2,000,000. It is an exponential moving average of the [LB_off] votes\n over a window of the most recent 2000 blocks that did not vote [LB_pass]. *)\n\nmodule Toggle_EMA : sig\n type t\n\n val of_int32 : Int32.t -> t tzresult Lwt.t\n\n val zero : t\n\n val to_int32 : t -> Int32.t\n\n val encoding : t Data_encoding.t\n\n val ( < ) : t -> Int32.t -> bool\nend\n\n(** [compute_new_ema ~toggle_vote old_ema] returns the value [new_ema] of the\n exponential moving average [old_ema] updated by the vote [toggle_vote].\n\n It is updated as follows:\n - if [toggle_vote] is [LB_pass] then [new_ema] = [old_ema],\n - if [toggle_vote] is [LB_off], then [new_ema] = (1999 * ema[n] // 2000) + 1,000,000,\n - if [toggle_vote] is [LB_on], then [new_ema] = (1999 * ema[n] // 2000).\n\n The multiplication is performed in [Z.t] to avoid overflows, division is\n rounded toward 1,000,000,000 (the middle of the interval).\n *)\nval compute_new_ema :\n toggle_vote:liquidity_baking_toggle_vote -> Toggle_EMA.t -> Toggle_EMA.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Tocqueville Group, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Options available for the Liquidity Baking per-block vote *)\n\ntype liquidity_baking_toggle_vote = LB_on | LB_off | LB_pass\n\nlet liquidity_baking_toggle_vote_encoding =\n let of_int8 = function\n | 0 -> Ok LB_on\n | 1 -> Ok LB_off\n | 2 -> Ok LB_pass\n | _ -> Error \"liquidity_baking_toggle_vote_of_int8\"\n in\n let to_int8 = function LB_on -> 0 | LB_off -> 1 | LB_pass -> 2 in\n let open Data_encoding in\n (* union *)\n def \"liquidity_baking_toggle_vote\"\n @@ splitted\n ~binary:(conv_with_guard to_int8 of_int8 int8)\n ~json:(string_enum [(\"on\", LB_on); (\"off\", LB_off); (\"pass\", LB_pass)])\n\nmodule Toggle_EMA : sig\n (* The exponential moving average is represented as an Int32 between 0l and 2_000_000_000l *)\n\n type t\n\n val zero : t\n\n val of_int32 : Int32.t -> t tzresult Lwt.t\n\n val to_int32 : t -> Int32.t\n\n val update_ema_off : t -> t\n\n val update_ema_on : t -> t\n\n val ( < ) : t -> Int32.t -> bool\n\n val encoding : t Data_encoding.t\nend = struct\n type t = Int32.t (* Invariant 0 <= ema <= 2_000_000_000l *)\n\n (* This error is not registered because we don't expect it to be\n raised. *)\n type error += Liquidity_baking_toggle_ema_out_of_bound of Int32.t\n\n let check_bounds x = Compare.Int32.(0l <= x && x <= 2_000_000_000l)\n\n let of_int32 x =\n if check_bounds x then return x\n else tzfail @@ Liquidity_baking_toggle_ema_out_of_bound x\n\n let zero = Int32.zero\n\n (* The conv_with_guard combinator of Data_encoding expects a (_, string) result. *)\n let of_int32_for_encoding x =\n if check_bounds x then Ok x else Error \"out of bounds\"\n\n let to_int32 ema = ema\n\n (* We perform the computations in Z to avoid overflows. *)\n\n let z_1999 = Z.of_int 1999\n\n let z_2000 = Z.of_int 2000\n\n let attenuate z = Z.(div (mul z_1999 z) z_2000)\n\n let z_1_000_000_000 = Z.of_int 1_000_000_000\n\n (* Outside of this module, the EMA is always between 0 and 2,000,000,000.\n This [recenter] wrappers, puts it in between -1,000,000,000 and 1,000,000,000.\n The goal of this recentering around zero is to make [update_ema_off] and\n [update_ema_on] behave symmetrically with respect to rounding. *)\n let recenter f ema = Z.(add z_1_000_000_000 (f (sub ema z_1_000_000_000)))\n\n let z_500_000 = Z.of_int 500_000\n\n let update_ema_off ema =\n let ema = Z.of_int32 ema in\n recenter (fun ema -> Z.add (attenuate ema) z_500_000) ema |> Z.to_int32\n\n let update_ema_on ema =\n let ema = Z.of_int32 ema in\n recenter (fun ema -> Z.sub (attenuate ema) z_500_000) ema |> Z.to_int32\n\n let ( < ) = Compare.Int32.( < )\n\n let encoding =\n Data_encoding.(conv_with_guard to_int32 of_int32_for_encoding int32)\nend\n\n(* Invariant: 0 <= ema <= 2_000_000 *)\nlet compute_new_ema ~toggle_vote ema =\n match toggle_vote with\n | LB_pass -> ema\n | LB_off -> Toggle_EMA.update_ema_off ema\n | LB_on -> Toggle_EMA.update_ema_on ema\n" ;
} ;
{ name = "Block_header_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Representation of block headers. *)\n\ntype contents = {\n payload_hash : Block_payload_hash.t;\n payload_round : Round_repr.t;\n seed_nonce_hash : Nonce_hash.t option;\n proof_of_work_nonce : bytes;\n liquidity_baking_toggle_vote :\n Liquidity_baking_repr.liquidity_baking_toggle_vote;\n}\n\ntype protocol_data = {contents : contents; signature : Signature.t}\n\ntype t = {shell : Block_header.shell_header; protocol_data : protocol_data}\n\ntype block_header = t\n\ntype raw = Block_header.t\n\ntype shell_header = Block_header.shell_header\n\nval raw : block_header -> raw\n\nval encoding : block_header Data_encoding.encoding\n\nval raw_encoding : raw Data_encoding.t\n\nval contents_encoding : contents Data_encoding.t\n\nval unsigned_encoding : (Block_header.shell_header * contents) Data_encoding.t\n\nval protocol_data_encoding : protocol_data Data_encoding.encoding\n\nval shell_header_encoding : shell_header Data_encoding.encoding\n\ntype block_watermark = Block_header of Chain_id.t\n\nval to_watermark : block_watermark -> Signature.watermark\n\nval of_watermark : Signature.watermark -> block_watermark option\n\n(** The maximum size of block headers in bytes *)\nval max_header_length : int\n\nval hash : block_header -> Block_hash.t\n\nval hash_raw : raw -> Block_hash.t\n\ntype error += (* Permanent *) Invalid_stamp\n\n(** Checks if the header that would be built from the given components\n is valid for the given difficulty. The signature is not passed as\n it is does not impact the proof-of-work stamp. The stamp is checked\n on the hash of a block header whose signature has been\n zeroed-out. *)\nmodule Proof_of_work : sig\n val check_hash : Block_hash.t -> int64 -> bool\n\n val check_header_proof_of_work_stamp :\n shell_header -> contents -> int64 -> bool\n\n val check_proof_of_work_stamp :\n proof_of_work_threshold:int64 -> block_header -> unit tzresult\nend\n\n(** [check_timestamp ctxt timestamp round predecessor_timestamp\n predecessor_round] verifies that the block's timestamp and round\n are coherent with the predecessor block's timestamp and\n round. Fails with an error if that is not the case. *)\nval check_timestamp :\n Round_repr.Durations.t ->\n timestamp:Time.t ->\n round:Round_repr.t ->\n predecessor_timestamp:Time.t ->\n predecessor_round:Round_repr.t ->\n unit tzresult\n\nval check_signature : t -> Chain_id.t -> Signature.Public_key.t -> unit tzresult\n\nval begin_validate_block_header :\n block_header:t ->\n chain_id:Chain_id.t ->\n predecessor_timestamp:Time.t ->\n predecessor_round:Round_repr.t ->\n fitness:Fitness_repr.t ->\n timestamp:Time.t ->\n delegate_pk:Signature.public_key ->\n round_durations:Round_repr.Durations.t ->\n proof_of_work_threshold:int64 ->\n expected_commitment:bool ->\n unit tzresult\n\ntype locked_round_evidence = {\n preendorsement_round : Round_repr.t;\n preendorsement_count : int;\n}\n\ntype checkable_payload_hash =\n | No_check\n | Expected_payload_hash of Block_payload_hash.t\n\nval finalize_validate_block_header :\n block_header_contents:contents ->\n round:Round_repr.t ->\n fitness:Fitness_repr.t ->\n checkable_payload_hash:checkable_payload_hash ->\n locked_round_evidence:locked_round_evidence option ->\n consensus_threshold:int ->\n unit tzresult\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Block header *)\n\ntype contents = {\n payload_hash : Block_payload_hash.t;\n payload_round : Round_repr.t;\n seed_nonce_hash : Nonce_hash.t option;\n proof_of_work_nonce : bytes;\n liquidity_baking_toggle_vote :\n Liquidity_baking_repr.liquidity_baking_toggle_vote;\n}\n\ntype protocol_data = {contents : contents; signature : Signature.t}\n\ntype t = {shell : Block_header.shell_header; protocol_data : protocol_data}\n\ntype block_header = t\n\ntype raw = Block_header.t\n\ntype shell_header = Block_header.shell_header\n\nlet raw_encoding = Block_header.encoding\n\nlet shell_header_encoding = Block_header.shell_header_encoding\n\ntype block_watermark = Block_header of Chain_id.t\n\nlet bytes_of_block_watermark = function\n | Block_header chain_id ->\n Bytes.cat (Bytes.of_string \"\\x11\") (Chain_id.to_bytes chain_id)\n\nlet to_watermark b = Signature.Custom (bytes_of_block_watermark b)\n\nlet of_watermark = function\n | Signature.Custom b ->\n if Compare.Int.(Bytes.length b > 0) then\n match Bytes.get b 0 with\n | '\\x11' ->\n Option.map\n (fun chain_id -> Block_header chain_id)\n (Chain_id.of_bytes_opt (Bytes.sub b 1 (Bytes.length b - 1)))\n | _ -> None\n else None\n | _ -> None\n\nlet contents_encoding =\n let open Data_encoding in\n def \"block_header.alpha.unsigned_contents\"\n @@ conv\n (fun {\n payload_hash;\n payload_round;\n seed_nonce_hash;\n proof_of_work_nonce;\n liquidity_baking_toggle_vote;\n } ->\n ( payload_hash,\n payload_round,\n proof_of_work_nonce,\n seed_nonce_hash,\n liquidity_baking_toggle_vote ))\n (fun ( payload_hash,\n payload_round,\n proof_of_work_nonce,\n seed_nonce_hash,\n liquidity_baking_toggle_vote ) ->\n {\n payload_hash;\n payload_round;\n seed_nonce_hash;\n proof_of_work_nonce;\n liquidity_baking_toggle_vote;\n })\n (obj5\n (req \"payload_hash\" Block_payload_hash.encoding)\n (req \"payload_round\" Round_repr.encoding)\n (req\n \"proof_of_work_nonce\"\n (Fixed.bytes Hex Constants_repr.proof_of_work_nonce_size))\n (opt \"seed_nonce_hash\" Nonce_hash.encoding)\n (req\n \"liquidity_baking_toggle_vote\"\n Liquidity_baking_repr.liquidity_baking_toggle_vote_encoding))\n\nlet protocol_data_encoding =\n let open Data_encoding in\n def \"block_header.alpha.signed_contents\"\n @@ conv\n (fun {contents; signature} -> (contents, signature))\n (fun (contents, signature) -> {contents; signature})\n (merge_objs\n contents_encoding\n (obj1 (req \"signature\" Signature.encoding)))\n\nlet raw {shell; protocol_data} =\n let protocol_data =\n Data_encoding.Binary.to_bytes_exn protocol_data_encoding protocol_data\n in\n {Block_header.shell; protocol_data}\n\nlet unsigned_encoding =\n let open Data_encoding in\n merge_objs Block_header.shell_header_encoding contents_encoding\n\nlet encoding =\n let open Data_encoding in\n def \"block_header.alpha.full_header\"\n @@ conv\n (fun {shell; protocol_data} -> (shell, protocol_data))\n (fun (shell, protocol_data) -> {shell; protocol_data})\n (merge_objs Block_header.shell_header_encoding protocol_data_encoding)\n\n(** Constants *)\n\nlet max_header_length =\n let fake_level = Raw_level_repr.root in\n let fake_round = Round_repr.zero in\n let fake_fitness =\n Fitness_repr.create_without_locked_round\n ~level:fake_level\n ~predecessor_round:fake_round\n ~round:fake_round\n in\n let fake_shell =\n {\n Block_header.level = 0l;\n proto_level = 0;\n predecessor = Block_hash.zero;\n timestamp = Time.of_seconds 0L;\n validation_passes = 0;\n operations_hash = Operation_list_list_hash.zero;\n fitness = Fitness_repr.to_raw fake_fitness;\n context = Context_hash.zero;\n }\n and fake_contents =\n {\n payload_hash = Block_payload_hash.zero;\n payload_round = Round_repr.zero;\n proof_of_work_nonce =\n Bytes.make Constants_repr.proof_of_work_nonce_size '0';\n seed_nonce_hash = Some Nonce_hash.zero;\n liquidity_baking_toggle_vote = LB_pass;\n }\n in\n Data_encoding.Binary.length\n encoding\n {\n shell = fake_shell;\n protocol_data = {contents = fake_contents; signature = Signature.zero};\n }\n\n(** Header parsing entry point *)\n\nlet hash_raw = Block_header.hash\n\nlet hash {shell; protocol_data} =\n Block_header.hash\n {\n shell;\n protocol_data =\n Data_encoding.Binary.to_bytes_exn protocol_data_encoding protocol_data;\n }\n\ntype locked_round_evidence = {\n preendorsement_round : Round_repr.t;\n preendorsement_count : int;\n}\n\ntype error +=\n | (* Permanent *)\n Invalid_block_signature of\n Block_hash.t * Signature.Public_key_hash.t\n | (* Permanent *) Invalid_stamp\n | (* Permanent *)\n Invalid_payload_hash of {\n expected : Block_payload_hash.t;\n provided : Block_payload_hash.t;\n }\n | (* Permanent *)\n Locked_round_after_block_round of {\n locked_round : Round_repr.t;\n round : Round_repr.t;\n }\n | (* Permanent *)\n Invalid_payload_round of {\n payload_round : Round_repr.t;\n round : Round_repr.t;\n }\n | (* Permanent *)\n Insufficient_locked_round_evidence of {\n voting_power : int;\n consensus_threshold : int;\n }\n | (* Permanent *) Invalid_commitment of {expected : bool}\n | (* Permanent *) Wrong_timestamp of Time.t * Time.t\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"block_header.invalid_block_signature\"\n ~title:\"Invalid block signature\"\n ~description:\"A block was not signed with the expected private key.\"\n ~pp:(fun ppf (block, pkh) ->\n Format.fprintf\n ppf\n \"Invalid signature for block %a. Expected: %a.\"\n Block_hash.pp_short\n block\n Signature.Public_key_hash.pp_short\n pkh)\n Data_encoding.(\n obj2\n (req \"block\" Block_hash.encoding)\n (req \"expected\" Signature.Public_key_hash.encoding))\n (function\n | Invalid_block_signature (block, pkh) -> Some (block, pkh) | _ -> None)\n (fun (block, pkh) -> Invalid_block_signature (block, pkh)) ;\n register_error_kind\n `Permanent\n ~id:\"block_header.invalid_stamp\"\n ~title:\"Insufficient block proof-of-work stamp\"\n ~description:\"The block's proof-of-work stamp is insufficient\"\n ~pp:(fun ppf () -> Format.fprintf ppf \"Insufficient proof-of-work stamp\")\n Data_encoding.empty\n (function Invalid_stamp -> Some () | _ -> None)\n (fun () -> Invalid_stamp) ;\n register_error_kind\n `Permanent\n ~id:\"block_header.invalid_payload_hash\"\n ~title:\"Invalid payload hash\"\n ~description:\"Invalid payload hash.\"\n ~pp:(fun ppf (expected, provided) ->\n Format.fprintf\n ppf\n \"Invalid payload hash (expected: %a, provided: %a).\"\n Block_payload_hash.pp_short\n expected\n Block_payload_hash.pp_short\n provided)\n Data_encoding.(\n obj2\n (req \"expected\" Block_payload_hash.encoding)\n (req \"provided\" Block_payload_hash.encoding))\n (function\n | Invalid_payload_hash {expected; provided} -> Some (expected, provided)\n | _ -> None)\n (fun (expected, provided) -> Invalid_payload_hash {expected; provided}) ;\n () ;\n register_error_kind\n `Permanent\n ~id:\"block_header.locked_round_after_block_round\"\n ~title:\"Locked round after block round\"\n ~description:\"Locked round after block round.\"\n ~pp:(fun ppf (locked_round, round) ->\n Format.fprintf\n ppf\n \"Locked round (%a) is after the block round (%a).\"\n Round_repr.pp\n locked_round\n Round_repr.pp\n round)\n Data_encoding.(\n obj2\n (req \"locked_round\" Round_repr.encoding)\n (req \"round\" Round_repr.encoding))\n (function\n | Locked_round_after_block_round {locked_round; round} ->\n Some (locked_round, round)\n | _ -> None)\n (fun (locked_round, round) ->\n Locked_round_after_block_round {locked_round; round}) ;\n () ;\n register_error_kind\n `Permanent\n ~id:\"block_header.invalid_payload_round\"\n ~title:\"Invalid payload round\"\n ~description:\"The given payload round is invalid.\"\n ~pp:(fun ppf (payload_round, round) ->\n Format.fprintf\n ppf\n \"The provided payload round (%a) is after the block round (%a).\"\n Round_repr.pp\n payload_round\n Round_repr.pp\n round)\n Data_encoding.(\n obj2\n (req \"payload_round\" Round_repr.encoding)\n (req \"round\" Round_repr.encoding))\n (function\n | Invalid_payload_round {payload_round; round} ->\n Some (payload_round, round)\n | _ -> None)\n (fun (payload_round, round) -> Invalid_payload_round {payload_round; round}) ;\n register_error_kind\n `Permanent\n ~id:\"block_header.insufficient_locked_round_evidence\"\n ~title:\"Insufficient locked round evidence\"\n ~description:\"Insufficient locked round evidence.\"\n ~pp:(fun ppf (voting_power, consensus_threshold) ->\n Format.fprintf\n ppf\n \"The provided locked round evidence is not sufficient: provided %d \\\n voting power but was expecting at least %d.\"\n voting_power\n consensus_threshold)\n Data_encoding.(\n obj2 (req \"voting_power\" int31) (req \"consensus_threshold\" int31))\n (function\n | Insufficient_locked_round_evidence {voting_power; consensus_threshold}\n ->\n Some (voting_power, consensus_threshold)\n | _ -> None)\n (fun (voting_power, consensus_threshold) ->\n Insufficient_locked_round_evidence {voting_power; consensus_threshold}) ;\n register_error_kind\n `Permanent\n ~id:\"block_header.invalid_commitment\"\n ~title:\"Invalid commitment in block header\"\n ~description:\"The block header has invalid commitment.\"\n ~pp:(fun ppf expected ->\n if expected then\n Format.fprintf ppf \"Missing seed's nonce commitment in block header.\"\n else\n Format.fprintf ppf \"Unexpected seed's nonce commitment in block header.\")\n Data_encoding.(obj1 (req \"expected\" bool))\n (function Invalid_commitment {expected} -> Some expected | _ -> None)\n (fun expected -> Invalid_commitment {expected}) ;\n register_error_kind\n `Permanent\n ~id:\"block_header.wrong_timestamp\"\n ~title:\"Wrong timestamp\"\n ~description:\"Block timestamp not the expected one.\"\n ~pp:(fun ppf (block_ts, expected_ts) ->\n Format.fprintf\n ppf\n \"Wrong timestamp: block timestamp (%a) not the expected one (%a)\"\n Time.pp_hum\n block_ts\n Time.pp_hum\n expected_ts)\n Data_encoding.(\n obj2\n (req \"block_timestamp\" Time.encoding)\n (req \"expected_timestamp\" Time.encoding))\n (function Wrong_timestamp (t1, t2) -> Some (t1, t2) | _ -> None)\n (fun (t1, t2) -> Wrong_timestamp (t1, t2))\n\nlet check_signature (block : t) (chain_id : Chain_id.t)\n (key : Signature.Public_key.t) =\n let check_signature key ({shell; protocol_data = {contents; signature}} : t) =\n let unsigned_header =\n Data_encoding.Binary.to_bytes_exn unsigned_encoding (shell, contents)\n in\n Signature.check\n ~watermark:(to_watermark (Block_header chain_id))\n key\n signature\n unsigned_header\n in\n if check_signature key block then ok ()\n else\n error (Invalid_block_signature (hash block, Signature.Public_key.hash key))\n\nlet check_payload_round ~round ~payload_round =\n error_when\n Round_repr.(payload_round > round)\n (Invalid_payload_round {payload_round; round})\n\nlet check_timestamp round_durations ~timestamp ~round ~predecessor_timestamp\n ~predecessor_round =\n Round_repr.timestamp_of_round\n round_durations\n ~predecessor_timestamp\n ~predecessor_round\n ~round\n >>? fun expected_timestamp ->\n if Time_repr.(expected_timestamp = timestamp) then Error_monad.ok ()\n else error (Wrong_timestamp (timestamp, expected_timestamp))\n\nmodule Proof_of_work = struct\n let check_hash hash stamp_threshold =\n let bytes = Block_hash.to_bytes hash in\n let word = TzEndian.get_int64 bytes 0 in\n Compare.Uint64.(word <= stamp_threshold)\n\n let check_header_proof_of_work_stamp shell contents stamp_threshold =\n let hash =\n hash {shell; protocol_data = {contents; signature = Signature.zero}}\n in\n check_hash hash stamp_threshold\n\n let check_proof_of_work_stamp ~proof_of_work_threshold block =\n if\n check_header_proof_of_work_stamp\n block.shell\n block.protocol_data.contents\n proof_of_work_threshold\n then ok ()\n else error Invalid_stamp\nend\n\nlet begin_validate_block_header ~(block_header : t) ~(chain_id : Chain_id.t)\n ~(predecessor_timestamp : Time.t) ~(predecessor_round : Round_repr.t)\n ~(fitness : Fitness_repr.t) ~(timestamp : Time.t)\n ~(delegate_pk : Signature.Public_key.t)\n ~(round_durations : Round_repr.Durations.t)\n ~(proof_of_work_threshold : int64) ~(expected_commitment : bool) =\n (* Level relationship between current node and the predecessor is\n done by the shell. We know that level is predecessor level + 1.\n The predecessor block hash is guaranteed by the shell to be the\n one in the shell header. The operations are guaranteed to\n correspond to the shell_header.operations_hash by the shell *)\n let {payload_round; seed_nonce_hash; _} =\n block_header.protocol_data.contents\n in\n let raw_level = block_header.shell.level in\n Proof_of_work.check_proof_of_work_stamp ~proof_of_work_threshold block_header\n >>? fun () ->\n Raw_level_repr.of_int32 raw_level >>? fun level ->\n check_signature block_header chain_id delegate_pk >>? fun () ->\n let round = Fitness_repr.round fitness in\n check_payload_round ~round ~payload_round >>? fun () ->\n check_timestamp\n round_durations\n ~predecessor_timestamp\n ~predecessor_round\n ~timestamp\n ~round\n >>? fun () ->\n Fitness_repr.check_except_locked_round fitness ~level ~predecessor_round\n >>? fun () ->\n let has_commitment =\n match seed_nonce_hash with None -> false | Some _ -> true\n in\n error_unless\n Compare.Bool.(has_commitment = expected_commitment)\n (Invalid_commitment {expected = expected_commitment})\n\ntype checkable_payload_hash =\n | No_check\n | Expected_payload_hash of Block_payload_hash.t\n\nlet finalize_validate_block_header ~(block_header_contents : contents)\n ~(round : Round_repr.t)\n ~(* We have to check the round because in the construction case it was\n deduced from the time *)\n (fitness : Fitness_repr.t)\n ~(checkable_payload_hash : checkable_payload_hash)\n ~(locked_round_evidence : locked_round_evidence option)\n ~(consensus_threshold : int) =\n let {\n payload_hash = actual_payload_hash;\n seed_nonce_hash = _;\n proof_of_work_nonce = _;\n _;\n } =\n block_header_contents\n in\n (match checkable_payload_hash with\n | No_check -> Result.return_unit\n | Expected_payload_hash bph ->\n error_unless\n (Block_payload_hash.equal actual_payload_hash bph)\n (Invalid_payload_hash {expected = bph; provided = actual_payload_hash}))\n >>? fun () ->\n (match locked_round_evidence with\n | None -> ok None\n | Some {preendorsement_count; preendorsement_round} ->\n error_when\n Round_repr.(preendorsement_round >= round)\n (Locked_round_after_block_round\n {locked_round = preendorsement_round; round})\n >>? fun () ->\n error_when\n Compare.Int.(preendorsement_count < consensus_threshold)\n (Insufficient_locked_round_evidence\n {voting_power = preendorsement_count; consensus_threshold})\n >>? fun () -> ok (Some preendorsement_round))\n >>? fun locked_round -> Fitness_repr.check_locked_round fitness ~locked_round\n" ;
} ;
{ name = "Destination_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxheadalpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** The type of the [destination] argument of the\n {!Operation_repr.Transaction} manager operation.\n\n The introduction of this type allows to interact with emerging\n layer-2 solutions using the API Tezos users and tooling\n are already used to: contract calls to entrypoint. These solutions\n cannot be integrated to {!Contract_repr.t} directly, because\n values of this type are given a balance, which has an impact on\n the delegation system. *)\n\n(** This type is a superset of the set of contracts ({!Contract_repr.t}).\n\n {b Note:} It is of key importance that the encoding of this type\n remains compatible with {!Contract_repr.encoding}, for the\n introduction to this type to remain transparent from the existing\n tooling perspective. *)\ntype t =\n | Contract of Contract_repr.t\n | Tx_rollup of Tx_rollup_repr.t\n | Sc_rollup of Sc_rollup_repr.t\n | Zk_rollup of Zk_rollup_repr.t\n\ninclude Compare.S with type t := t\n\nval to_b58check : t -> string\n\nval of_b58check : string -> t tzresult\n\nval encoding : t Data_encoding.t\n\nval pp : Format.formatter -> t -> unit\n\n(** [in_memory_size contract] returns the number of bytes that are\n allocated in the RAM for [contract]. *)\nval in_memory_size : t -> Cache_memory_helpers.sint\n\ntype error += Invalid_destination_b58check of string\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxheadalpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t =\n | Contract of Contract_repr.t\n | Tx_rollup of Tx_rollup_repr.t\n | Sc_rollup of Sc_rollup_repr.t\n | Zk_rollup of Zk_rollup_repr.t\n\n(* If you add more cases to this type, please update the\n [test_compare_destination] test in\n [test/unit/test_destination_repr.ml] to ensure that the compare\n function keeps its expected behavior to distinguish between\n implicit accounts and smart contracts. *)\n\ninclude Compare.Make (struct\n type nonrec t = t\n\n let compare l1 l2 =\n match (l1, l2) with\n | Contract k1, Contract k2 -> Contract_repr.compare k1 k2\n | Tx_rollup k1, Tx_rollup k2 -> Tx_rollup_repr.compare k1 k2\n | Sc_rollup k1, Sc_rollup k2 -> Sc_rollup_repr.Address.compare k1 k2\n | Zk_rollup k1, Zk_rollup k2 -> Zk_rollup_repr.Address.compare k1 k2\n (* This function is used by the Michelson interpreter to compare\n addresses. It is of significant importance to remember that in\n Michelson, address comparison is used to distinguish between\n KT1 and tz1. As a consequence, we want to preserve that [tz1 <\n KT1 < others], which the two following lines ensure. The\n wildcards are therefore here for a reason, and should not be\n modified when new constructors are added to [t]. *)\n | Contract _, _ -> -1\n | _, Contract _ -> 1\n | Tx_rollup _, _ -> -1\n | _, Tx_rollup _ -> 1\n | Sc_rollup _, _ -> -1\n | _, Sc_rollup _ -> 1\nend)\n\nlet to_b58check = function\n | Contract k -> Contract_repr.to_b58check k\n | Tx_rollup k -> Tx_rollup_repr.to_b58check k\n | Sc_rollup k -> Sc_rollup_repr.Address.to_b58check k\n | Zk_rollup k -> Zk_rollup_repr.Address.to_b58check k\n\ntype error += Invalid_destination_b58check of string\n\nlet () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"destination_repr.invalid_b58check\"\n ~title:\"Destination decoding failed\"\n ~description:\n \"Failed to read a valid destination from a b58check_encoding data\"\n (obj1 (req \"input\" (string Plain)))\n (function Invalid_destination_b58check x -> Some x | _ -> None)\n (fun x -> Invalid_destination_b58check x)\n\nlet of_b58data data =\n let decode_on_none decode wrap = function\n | Some x -> Some x\n | None -> Option.map wrap @@ decode data\n in\n None\n |> decode_on_none Contract_repr.of_b58data (fun c -> Contract c)\n |> decode_on_none Tx_rollup_repr.of_b58data (fun t -> Tx_rollup t)\n |> decode_on_none Sc_rollup_repr.Address.of_b58data (fun s -> Sc_rollup s)\n |> decode_on_none Zk_rollup_repr.Address.of_b58data (fun z -> Zk_rollup z)\n\nlet of_b58check_opt s = Option.bind (Base58.decode s) of_b58data\n\nlet of_b58check s =\n match of_b58check_opt s with\n | None -> error (Invalid_destination_b58check s)\n | Some dest -> Ok dest\n\nlet encoding =\n let open Data_encoding in\n def\n \"transaction_destination\"\n ~title:\"A destination of a transaction\"\n ~description:\n \"A destination notation compatible with the contract notation as given \\\n to an RPC or inside scripts. Can be a base58 implicit contract hash, a \\\n base58 originated contract hash, a base58 originated transaction \\\n rollup, or a base58 originated smart rollup.\"\n @@ splitted\n ~binary:\n (union\n ~tag_size:`Uint8\n (Contract_repr.cases\n (function Contract x -> Some x | _ -> None)\n (fun x -> Contract x)\n @ [\n case\n (Tag 2)\n (Fixed.add_padding Tx_rollup_repr.encoding 1)\n ~title:\"Tx_rollup\"\n (function Tx_rollup k -> Some k | _ -> None)\n (fun k -> Tx_rollup k);\n case\n (Tag 3)\n (Fixed.add_padding Sc_rollup_repr.Address.encoding 1)\n ~title:\"Smart_rollup\"\n (function Sc_rollup k -> Some k | _ -> None)\n (fun k -> Sc_rollup k);\n case\n (Tag 4)\n (Fixed.add_padding Zk_rollup_repr.Address.encoding 1)\n ~title:\"Zk_rollup\"\n (function Zk_rollup k -> Some k | _ -> None)\n (fun k -> Zk_rollup k);\n ]))\n ~json:\n (conv\n to_b58check\n (fun s ->\n match of_b58check s with\n | Ok s -> s\n | Error _ ->\n Data_encoding.Json.cannot_destruct\n \"Invalid destination notation.\")\n (string Plain))\n\nlet pp : Format.formatter -> t -> unit =\n fun fmt -> function\n | Contract k -> Contract_repr.pp fmt k\n | Tx_rollup k -> Tx_rollup_repr.pp fmt k\n | Sc_rollup k -> Sc_rollup_repr.pp fmt k\n | Zk_rollup k -> Zk_rollup_repr.Address.pp fmt k\n\nlet in_memory_size =\n let open Cache_memory_helpers in\n function\n | Contract k -> h1w +! Contract_repr.in_memory_size k\n | Tx_rollup k -> h1w +! Tx_rollup_repr.in_memory_size k\n | Sc_rollup k -> h1w +! Sc_rollup_repr.in_memory_size k\n | Zk_rollup k -> h1w +! Zk_rollup_repr.in_memory_size k\n" ;
} ;
{ name = "Script_int" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** The types for arbitrary precision integers in Michelson.\n The type variable ['t] is always [n] or [z],\n [n num] and [z num] are incompatible.\n\n This is internally a [Z.t].\n This module mostly adds signedness preservation guarantees. *)\ntype 't repr\n\n(** [num] is made algebraic in order to distinguish it from the other type\n parameters of [Script_typed_ir.ty]. *)\ntype 't num = Num_tag of 't repr [@@ocaml.unboxed]\n\n(** Flag for natural numbers. *)\ntype n = Natural_tag\n\n(** Flag for relative numbers. *)\ntype z = Integer_tag\n\n(** Natural zero. *)\nval zero_n : n num\n\n(** Natural one. *)\nval one_n : n num\n\n(** Natural successor.\n\n [succ_n x] is the same as [add_n one_n].\n *)\nval succ_n : n num -> n num\n\n(** Relative zero. *)\nval zero : z num\n\n(** Relative one. *)\nval one : z num\n\n(** Compare two numbers as if they were *)\nval compare : 'a num -> 'a num -> int\n\n(** Conversion to an OCaml [string] in decimal notation. *)\nval to_string : _ num -> string\n\n(** Conversion from an OCaml [string].\n Returns [None] in case of an invalid notation.\n Supports [+] and [-] sign modifiers, and [0x], [0o] and [0b] base modifiers. *)\nval of_string : string -> z num option\n\n(** Conversion from an OCaml [int32]. *)\nval of_int32 : int32 -> z num\n\n(** Conversion to an OCaml [int64], returns [None] on overflow. *)\nval to_int64 : _ num -> int64 option\n\n(** Conversion from an OCaml [int64]. *)\nval of_int64 : int64 -> z num\n\n(** Conversion to an OCaml [int], returns [None] on overflow. *)\nval to_int : _ num -> int option\n\n(** Conversion from an OCaml [int]. *)\nval of_int : int -> z num\n\n(** Conversion from a Zarith integer ([Z.t]). *)\nval of_zint : Z.t -> z num\n\n(** Conversion to a Zarith integer ([Z.t]). *)\nval to_zint : 'a num -> Z.t\n\n(** Addition between naturals. *)\nval add_n : n num -> n num -> n num\n\n(** Multiplication with a natural. *)\nval mul_n : n num -> 'a num -> 'a num\n\n(** Euclidean division of a natural.\n [ediv_n n d] returns [None] if divisor is zero,\n or [Some (q, r)] where [n = d * q + r] and [[0 <= r < d]] otherwise. *)\nval ediv_n : n num -> 'a num -> ('a num * n num) option\n\n(** Sign agnostic addition.\n Use {!add_n} when working with naturals to preserve the sign. *)\nval add : _ num -> _ num -> z num\n\n(** Sign agnostic subtraction.\n Use {!sub_n} when working with naturals to preserve the sign. *)\nval sub : _ num -> _ num -> z num\n\n(** Sign agnostic multiplication.\n Use {!mul_n} when working with a natural to preserve the sign. *)\nval mul : _ num -> _ num -> z num\n\n(** Sign agnostic euclidean division.\n [ediv n d] returns [None] if divisor is zero,\n or [Some (q, r)] where [n = d * q + r] and [[0 <= r < |d|]] otherwise.\n Use {!ediv_n} when working with a natural to preserve the sign. *)\nval ediv : _ num -> _ num -> (z num * n num) option\n\n(** Compute the absolute value of a relative, turning it into a natural. *)\nval abs : z num -> n num\n\n(** Partial identity over [N]. *)\nval is_nat : z num -> n num option\n\n(** Negates a number. *)\nval neg : _ num -> z num\n\n(** Turns a natural into a relative, not changing its value. *)\nval int : n num -> z num\n\n(** Reverses each bit in the representation of the number.\n Also applies to the sign. *)\nval lognot : _ num -> z num\n\n(** Shifts the natural to the left of a number of bits between 0 and 256.\n Returns [None] if the amount is too high. *)\nval shift_left_n : n num -> n num -> n num option\n\n(** Shifts the natural to the right of a number of bits between 0 and 256.\n Returns [None] if the amount is too high. *)\nval shift_right_n : n num -> n num -> n num option\n\n(** Shifts the number to the left of a number of bits between 0 and 256.\n Returns [None] if the amount is too high. *)\nval shift_left : 'a num -> n num -> 'a num option\n\n(** Shifts the number to the right of a number of bits between 0 and 256.\n Returns [None] if the amount is too high. *)\nval shift_right : 'a num -> n num -> 'a num option\n\n(** Applies a boolean or operation to each bit. *)\nval logor : 'a num -> 'a num -> 'a num\n\n(** Applies a boolean and operation to each bit. *)\nval logand : _ num -> n num -> n num\n\n(** Applies a boolean xor operation to each bit. *)\nval logxor : n num -> n num -> n num\n\n(** Naturals are encoded using Data_encoding.n *)\nval n_encoding : n num Data_encoding.encoding\n\n(** Integers are encoded using Data_encoding.z *)\nval z_encoding : z num Data_encoding.encoding\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype n = Natural_tag\n\ntype z = Integer_tag\n\n(* We could define `num` as a GADT with constructors for `n` and `z`.\n This would enable factorizing the code a bit in the Michelson interpreter and\n also make formal the claim that `num` is only instantiated with `n` and `z`,\n but it would result in space and time overheads when manipulating `num`s, by\n having to deconstruct to and reconstruct from `Z.t`. *)\ntype 't repr = Z.t\n\ntype 't num = Num_tag of 't repr [@@ocaml.unboxed]\n\nlet compare (Num_tag x) (Num_tag y) = Z.compare x y\n\nlet zero = Num_tag Z.zero\n\nlet one = Num_tag Z.one\n\nlet zero_n = Num_tag Z.zero\n\nlet one_n = Num_tag Z.one\n\nlet to_string (Num_tag x) = Z.to_string x\n\nlet of_string s = Option.catch (fun () -> Num_tag (Z.of_string s))\n\nlet of_int32 n = Num_tag (Z.of_int64 @@ Int64.of_int32 n)\n\nlet to_int64 (Num_tag x) = Option.catch (fun () -> Z.to_int64 x)\n\nlet of_int64 n = Num_tag (Z.of_int64 n)\n\nlet to_int (Num_tag x) = Option.catch (fun () -> Z.to_int x)\n\nlet of_int n = Num_tag (Z.of_int n)\n\nlet of_zint x = Num_tag x\n\nlet to_zint (Num_tag x) = x\n\nlet add (Num_tag x) (Num_tag y) = Num_tag (Z.add x y)\n\nlet sub (Num_tag x) (Num_tag y) = Num_tag (Z.sub x y)\n\nlet mul (Num_tag x) (Num_tag y) = Num_tag (Z.mul x y)\n\nlet ediv (Num_tag x) (Num_tag y) =\n let ediv_tagged x y =\n let quo, rem = Z.ediv_rem x y in\n (Num_tag quo, Num_tag rem)\n in\n Option.catch (fun () -> ediv_tagged x y)\n\nlet add_n = add\n\nlet succ_n (Num_tag x) = Num_tag (Z.succ x)\n\nlet mul_n = mul\n\nlet ediv_n = ediv\n\nlet abs (Num_tag x) = Num_tag (Z.abs x)\n\nlet is_nat (Num_tag x) =\n if Compare.Z.(x < Z.zero) then None else Some (Num_tag x)\n\nlet neg (Num_tag x) = Num_tag (Z.neg x)\n\nlet int (Num_tag x) = Num_tag x\n\nlet shift_left (Num_tag x) (Num_tag y) =\n if Compare.Int.(Z.compare y (Z.of_int 256) > 0) then None\n else\n let y = Z.to_int y in\n Some (Num_tag (Z.shift_left x y))\n\nlet shift_right (Num_tag x) (Num_tag y) =\n if Compare.Int.(Z.compare y (Z.of_int 256) > 0) then None\n else\n let y = Z.to_int y in\n Some (Num_tag (Z.shift_right x y))\n\nlet shift_left_n = shift_left\n\nlet shift_right_n = shift_right\n\nlet logor (Num_tag x) (Num_tag y) = Num_tag (Z.logor x y)\n\nlet logxor (Num_tag x) (Num_tag y) = Num_tag (Z.logxor x y)\n\nlet logand (Num_tag x) (Num_tag y) = Num_tag (Z.logand x y)\n\nlet lognot (Num_tag x) = Num_tag (Z.lognot x)\n\nlet z_encoding : z num Data_encoding.encoding =\n Data_encoding.(conv (fun (Num_tag z) -> z) (fun z -> Num_tag z) z)\n\nlet n_encoding : n num Data_encoding.encoding =\n Data_encoding.(conv (fun (Num_tag n) -> n) (fun n -> Num_tag n) n)\n" ;
} ;
{ name = "Ticket_amount" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold, <contact@marigold.dev> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Script_int\n\n(* A type for ticket amount values to ensure positivity *)\ntype t = private n num\n\nval encoding : t Data_encoding.t\n\n(* Converts a natural number to a ticket amount value unless the input is zero *)\nval of_n : n num -> t option\n\n(* Converts a integral number to a ticket amount value unless the input is not positive *)\nval of_z : z num -> t option\n\nval of_zint : Z.t -> t option\n\nval add : t -> t -> t\n\n(* Subtract among ticket amount values unless the resultant amount is not positive *)\nval sub : t -> t -> t option\n\nval one : t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold, <contact@marigold.dev> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Script_int\n\ntype t = n num\n\nlet of_n n =\n if Compare.Int.(Script_int.(compare n zero_n) > 0) then Some (n : t) else None\n\nlet of_z z = Option.bind (is_nat z) of_n\n\nlet of_zint z = of_z @@ of_zint z\n\nlet add = add_n\n\nlet sub a b = of_z @@ sub a b\n\nlet one = one_n\n\nlet encoding =\n let open Data_encoding in\n conv_with_guard\n to_zint\n (fun n -> Option.value_e ~error:\"expecting positive number\" @@ of_zint n)\n n\n" ;
} ;
{ name = "Operation_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Tezos Protocol Implementation - Low level Repr. of Operations\n\n Defines kinds of operations that can be performed on chain:\n - preendorsement\n - endorsement\n - double baking evidence\n - double preendorsing evidence\n - double endorsing evidence\n - seed nonce revelation\n - account activation\n - proposal (see: [Voting_repr])\n - ballot (see: [Voting_repr])\n - failing noop\n - manager operation (which in turn has several types):\n - revelation\n - transaction\n - origination\n - delegation\n - set deposits limitation\n - tx rollup origination\n - tx rollup batch submission\n - tx rollup commit\n - tx rollup withdraw\n - tx rollup reveal withdrawals\n - smart contract rollup origination\n - zk rollup origination\n - zk rollup publish\n - zk rollup update\n\n Each of them can be encoded as raw bytes. Operations are distinguished at\n type level using phantom type parameters. [packed_operation] type allows\n for unifying them when required, for instance to put them on a single\n list. *)\n\nmodule Kind : sig\n type preendorsement_consensus_kind = Preendorsement_consensus_kind\n\n type endorsement_consensus_kind = Endorsement_consensus_kind\n\n type 'a consensus =\n | Preendorsement_kind : preendorsement_consensus_kind consensus\n | Endorsement_kind : endorsement_consensus_kind consensus\n\n type preendorsement = preendorsement_consensus_kind consensus\n\n type endorsement = endorsement_consensus_kind consensus\n\n type dal_attestation = Dal_attestation_kind\n\n type seed_nonce_revelation = Seed_nonce_revelation_kind\n\n type vdf_revelation = Vdf_revelation_kind\n\n type 'a double_consensus_operation_evidence =\n | Double_consensus_operation_evidence\n\n type double_endorsement_evidence =\n endorsement_consensus_kind double_consensus_operation_evidence\n\n type double_preendorsement_evidence =\n preendorsement_consensus_kind double_consensus_operation_evidence\n\n type double_baking_evidence = Double_baking_evidence_kind\n\n type activate_account = Activate_account_kind\n\n type proposals = Proposals_kind\n\n type ballot = Ballot_kind\n\n type reveal = Reveal_kind\n\n type transaction = Transaction_kind\n\n type origination = Origination_kind\n\n type delegation = Delegation_kind\n\n type event = Event_kind\n\n type set_deposits_limit = Set_deposits_limit_kind\n\n type increase_paid_storage = Increase_paid_storage_kind\n\n type update_consensus_key = Update_consensus_key_kind\n\n type drain_delegate = Drain_delegate_kind\n\n type failing_noop = Failing_noop_kind\n\n type register_global_constant = Register_global_constant_kind\n\n type tx_rollup_origination = Tx_rollup_origination_kind\n\n type tx_rollup_submit_batch = Tx_rollup_submit_batch_kind\n\n type tx_rollup_commit = Tx_rollup_commit_kind\n\n type tx_rollup_return_bond = Tx_rollup_return_bond_kind\n\n type tx_rollup_finalize_commitment = Tx_rollup_finalize_commitment_kind\n\n type tx_rollup_remove_commitment = Tx_rollup_remove_commitment_kind\n\n type tx_rollup_rejection = Tx_rollup_rejection_kind\n\n type tx_rollup_dispatch_tickets = Tx_rollup_dispatch_tickets_kind\n\n type transfer_ticket = Transfer_ticket_kind\n\n type dal_publish_slot_header = Dal_publish_slot_header_kind\n\n type sc_rollup_originate = Sc_rollup_originate_kind\n\n type sc_rollup_add_messages = Sc_rollup_add_messages_kind\n\n type sc_rollup_cement = Sc_rollup_cement_kind\n\n type sc_rollup_publish = Sc_rollup_publish_kind\n\n type sc_rollup_refute = Sc_rollup_refute_kind\n\n type sc_rollup_timeout = Sc_rollup_timeout_kind\n\n type sc_rollup_execute_outbox_message =\n | Sc_rollup_execute_outbox_message_kind\n\n type sc_rollup_recover_bond = Sc_rollup_recover_bond_kind\n\n type zk_rollup_origination = Zk_rollup_origination_kind\n\n type zk_rollup_publish = Zk_rollup_publish_kind\n\n type zk_rollup_update = Zk_rollup_update_kind\n\n type 'a manager =\n | Reveal_manager_kind : reveal manager\n | Transaction_manager_kind : transaction manager\n | Origination_manager_kind : origination manager\n | Delegation_manager_kind : delegation manager\n | Event_manager_kind : event manager\n | Register_global_constant_manager_kind : register_global_constant manager\n | Set_deposits_limit_manager_kind : set_deposits_limit manager\n | Increase_paid_storage_manager_kind : increase_paid_storage manager\n | Update_consensus_key_manager_kind : update_consensus_key manager\n | Tx_rollup_origination_manager_kind : tx_rollup_origination manager\n | Tx_rollup_submit_batch_manager_kind : tx_rollup_submit_batch manager\n | Tx_rollup_commit_manager_kind : tx_rollup_commit manager\n | Tx_rollup_return_bond_manager_kind : tx_rollup_return_bond manager\n | Tx_rollup_finalize_commitment_manager_kind\n : tx_rollup_finalize_commitment manager\n | Tx_rollup_remove_commitment_manager_kind\n : tx_rollup_remove_commitment manager\n | Tx_rollup_rejection_manager_kind : tx_rollup_rejection manager\n | Tx_rollup_dispatch_tickets_manager_kind\n : tx_rollup_dispatch_tickets manager\n | Transfer_ticket_manager_kind : transfer_ticket manager\n | Dal_publish_slot_header_manager_kind : dal_publish_slot_header manager\n | Sc_rollup_originate_manager_kind : sc_rollup_originate manager\n | Sc_rollup_add_messages_manager_kind : sc_rollup_add_messages manager\n | Sc_rollup_cement_manager_kind : sc_rollup_cement manager\n | Sc_rollup_publish_manager_kind : sc_rollup_publish manager\n | Sc_rollup_refute_manager_kind : sc_rollup_refute manager\n | Sc_rollup_timeout_manager_kind : sc_rollup_timeout manager\n | Sc_rollup_execute_outbox_message_manager_kind\n : sc_rollup_execute_outbox_message manager\n | Sc_rollup_recover_bond_manager_kind : sc_rollup_recover_bond manager\n | Zk_rollup_origination_manager_kind : zk_rollup_origination manager\n | Zk_rollup_publish_manager_kind : zk_rollup_publish manager\n | Zk_rollup_update_manager_kind : zk_rollup_update manager\nend\n\ntype 'a consensus_operation_type =\n | Endorsement : Kind.endorsement consensus_operation_type\n | Preendorsement : Kind.preendorsement consensus_operation_type\n\nval pp_operation_kind :\n Format.formatter -> 'kind consensus_operation_type -> unit\n\ntype consensus_content = {\n slot : Slot_repr.t;\n (* By convention, this is the validator's first slot. *)\n level : Raw_level_repr.t;\n (* The level of (pre)endorsed block. *)\n round : Round_repr.t;\n (* The round of (pre)endorsed block. *)\n block_payload_hash : Block_payload_hash.t;\n (* The payload hash of (pre)endorsed block. *)\n}\n\nval consensus_content_encoding : consensus_content Data_encoding.t\n\nval pp_consensus_content : Format.formatter -> consensus_content -> unit\n\ntype consensus_watermark =\n | Endorsement of Chain_id.t\n | Preendorsement of Chain_id.t\n | Dal_attestation of Chain_id.t\n\nval to_watermark : consensus_watermark -> Signature.watermark\n\nval of_watermark : Signature.watermark -> consensus_watermark option\n\ntype raw = Operation.t = {shell : Operation.shell_header; proto : bytes}\n\nval raw_encoding : raw Data_encoding.t\n\n(** An [operation] contains the operation header information in [shell]\n and all data related to the operation itself in [protocol_data]. *)\ntype 'kind operation = {\n shell : Operation.shell_header;\n protocol_data : 'kind protocol_data;\n}\n\n(** A [protocol_data] wraps together a signature for the operation and\n the contents of the operation itself. *)\nand 'kind protocol_data = {\n contents : 'kind contents_list;\n signature : Signature.t option;\n}\n\n(** A [contents_list] is a list of contents, the GADT guarantees two\n invariants:\n - the list is not empty, and\n - if the list has several elements then it only contains manager\n operations. *)\nand _ contents_list =\n | Single : 'kind contents -> 'kind contents_list\n | Cons :\n 'kind Kind.manager contents * 'rest Kind.manager contents_list\n -> ('kind * 'rest) Kind.manager contents_list\n\n(** A value of type [contents] an operation related to whether\n consensus, governance or contract management. *)\nand _ contents =\n (* Preendorsement: About consensus, preendorsement of a block held by a\n validator (specific to Tenderbake). *)\n | Preendorsement : consensus_content -> Kind.preendorsement contents\n (* Endorsement: About consensus, endorsement of a block held by a\n validator. *)\n | Endorsement : consensus_content -> Kind.endorsement contents\n (* DAL/FIXME https://gitlab.com/tezos/tezos/-/issues/3115\n\n Temporary operation to avoid modifying endorsement encoding. *)\n | Dal_attestation :\n Dal_attestation_repr.operation\n -> Kind.dal_attestation contents\n (* Seed_nonce_revelation: Nonces are created by bakers and are\n combined to create pseudo-random seeds. Bakers are urged to reveal their\n nonces after a given number of cycles to keep their block rewards\n from being forfeited. *)\n | Seed_nonce_revelation : {\n level : Raw_level_repr.t;\n nonce : Seed_repr.nonce;\n }\n -> Kind.seed_nonce_revelation contents\n (* Vdf_revelation: VDF are computed from the seed generated by the revealed\n nonces. *)\n | Vdf_revelation : {\n solution : Seed_repr.vdf_solution;\n }\n -> Kind.vdf_revelation contents\n (* Double_preendorsement_evidence: Double-preendorsement is a\n kind of malicious attack where a byzantine attempts to fork\n the chain by preendorsing blocks with different\n contents (at the same level and same round)\n twice. This behavior may be reported and the byzantine will have\n its security deposit forfeited. *)\n | Double_preendorsement_evidence : {\n op1 : Kind.preendorsement operation;\n op2 : Kind.preendorsement operation;\n }\n -> Kind.double_preendorsement_evidence contents\n (* Double_endorsement_evidence: Similar to double-preendorsement but\n for endorsements. *)\n | Double_endorsement_evidence : {\n op1 : Kind.endorsement operation;\n op2 : Kind.endorsement operation;\n }\n -> Kind.double_endorsement_evidence contents\n (* Double_baking_evidence: Similarly to double-endorsement but the\n byzantine attempts to fork by signing two different blocks at the\n same level. *)\n | Double_baking_evidence : {\n bh1 : Block_header_repr.t;\n bh2 : Block_header_repr.t;\n }\n -> Kind.double_baking_evidence contents\n (* Activate_account: Account activation allows to register a public\n key hash on the blockchain. *)\n | Activate_account : {\n id : Ed25519.Public_key_hash.t;\n activation_code : Blinded_public_key_hash.activation_code;\n }\n -> Kind.activate_account contents\n (* Proposals: A candidate protocol can be proposed for voting. *)\n | Proposals : {\n source : Signature.Public_key_hash.t;\n period : int32;\n proposals : Protocol_hash.t list;\n }\n -> Kind.proposals contents\n (* Ballot: The validators of the chain will then vote on proposals. *)\n | Ballot : {\n source : Signature.Public_key_hash.t;\n period : int32;\n proposal : Protocol_hash.t;\n ballot : Vote_repr.ballot;\n }\n -> Kind.ballot contents\n (* [Drain_delegate { consensus_key ; delegate ; destination }]\n transfers the spendable balance of the [delegate] to [destination]\n when [consensus_key] is the active consensus key of [delegate].. *)\n | Drain_delegate : {\n consensus_key : Signature.Public_key_hash.t;\n delegate : Signature.Public_key_hash.t;\n destination : Signature.Public_key_hash.t;\n }\n -> Kind.drain_delegate contents\n (* Failing_noop: An operation never considered by the state machine\n and which will always fail at [apply]. This allows end-users to\n sign arbitrary messages which have no computational semantics. *)\n | Failing_noop : string -> Kind.failing_noop contents\n (* Manager_operation: Operations, emitted and signed by\n a (revealed) implicit account, that describe management and\n interactions between contracts (whether implicit or\n smart). *)\n | Manager_operation : {\n source : Signature.Public_key_hash.t;\n fee : Tez_repr.tez;\n counter : Manager_counter_repr.t;\n operation : 'kind manager_operation;\n gas_limit : Gas_limit_repr.Arith.integral;\n storage_limit : Z.t;\n }\n -> 'kind Kind.manager contents\n\n(** A [manager_operation] describes management and interactions\n between contracts (whether implicit or smart). *)\nand _ manager_operation =\n (* [Reveal] for the revelation of a public key, a one-time\n prerequisite to any signed operation, in order to be able to\n check the sender\226\128\153s signature. *)\n | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation\n (* [Transaction] of some amount to some destination contract. It can\n also be used to execute/call smart-contracts. *)\n | Transaction : {\n amount : Tez_repr.tez;\n parameters : Script_repr.lazy_expr;\n entrypoint : Entrypoint_repr.t;\n destination : Contract_repr.t;\n }\n -> Kind.transaction manager_operation\n (* [Origination] of a contract using a smart-contract [script] and\n initially credited with the amount [credit]. *)\n | Origination : {\n delegate : Signature.Public_key_hash.t option;\n script : Script_repr.t;\n credit : Tez_repr.tez;\n }\n -> Kind.origination manager_operation\n (* [Delegation] to some staking contract (designated by its public\n key hash). When this value is None, delegation is reverted as it\n is set to nobody. *)\n | Delegation :\n Signature.Public_key_hash.t option\n -> Kind.delegation manager_operation\n (* [Register_global_constant] allows registration and substitution\n of a global constant available from any contract and registered in\n the context. *)\n | Register_global_constant : {\n value : Script_repr.lazy_expr;\n }\n -> Kind.register_global_constant manager_operation\n (* [Set_deposits_limit] sets an optional limit for frozen deposits\n of a contract at a lower value than the maximum limit. When None,\n the limit in unset back to the default maximum limit. *)\n | Set_deposits_limit :\n Tez_repr.t option\n -> Kind.set_deposits_limit manager_operation\n (* [Increase_paid_storage] allows a sender to pay to increase the paid storage of\n some contract by some amount. *)\n | Increase_paid_storage : {\n amount_in_bytes : Z.t;\n destination : Contract_hash.t;\n }\n -> Kind.increase_paid_storage manager_operation\n (* [Update_consensus_key pk] updates the consensus key of\n the signing delegate to [pk]. *)\n | Update_consensus_key :\n Signature.Public_key.t\n -> Kind.update_consensus_key manager_operation\n (* [Tx_rollup_origination] allows an implicit contract to originate\n a new transactional rollup. *)\n | Tx_rollup_origination : Kind.tx_rollup_origination manager_operation\n (* [Tx_rollup_submit_batch] allows to submit batches of L2 operations on a\n transactional rollup. The content is a string, but stands for an immutable\n byte sequence. *)\n | Tx_rollup_submit_batch : {\n tx_rollup : Tx_rollup_repr.t;\n content : string;\n burn_limit : Tez_repr.t option;\n }\n -> Kind.tx_rollup_submit_batch manager_operation\n | Tx_rollup_commit : {\n tx_rollup : Tx_rollup_repr.t;\n commitment : Tx_rollup_commitment_repr.Full.t;\n }\n -> Kind.tx_rollup_commit manager_operation\n | Tx_rollup_return_bond : {\n tx_rollup : Tx_rollup_repr.t;\n }\n -> Kind.tx_rollup_return_bond manager_operation\n | Tx_rollup_finalize_commitment : {\n tx_rollup : Tx_rollup_repr.t;\n }\n -> Kind.tx_rollup_finalize_commitment manager_operation\n | Tx_rollup_remove_commitment : {\n tx_rollup : Tx_rollup_repr.t;\n }\n -> Kind.tx_rollup_remove_commitment manager_operation\n | Tx_rollup_rejection : {\n tx_rollup : Tx_rollup_repr.t;\n level : Tx_rollup_level_repr.t;\n message : Tx_rollup_message_repr.t;\n message_position : int;\n message_path : Tx_rollup_inbox_repr.Merkle.path;\n message_result_hash : Tx_rollup_message_result_hash_repr.t;\n message_result_path : Tx_rollup_commitment_repr.Merkle.path;\n previous_message_result : Tx_rollup_message_result_repr.t;\n previous_message_result_path : Tx_rollup_commitment_repr.Merkle.path;\n proof : Tx_rollup_l2_proof.serialized;\n }\n -> Kind.tx_rollup_rejection manager_operation\n | Tx_rollup_dispatch_tickets : {\n tx_rollup : Tx_rollup_repr.t;\n (** The rollup from where the tickets are retrieved *)\n level : Tx_rollup_level_repr.t;\n (** The level at which the withdrawal was enabled *)\n context_hash : Context_hash.t;\n (** The hash of the l2 context resulting from the execution of the\n inbox from where this withdrawal was enabled. *)\n message_index : int;\n (** Index of the message in the inbox at [level] where this withdrawal was enabled. *)\n message_result_path : Tx_rollup_commitment_repr.Merkle.path;\n tickets_info : Tx_rollup_reveal_repr.t list;\n }\n -> Kind.tx_rollup_dispatch_tickets manager_operation\n (** [Transfer_ticket] allows an implicit account (the \"claimer\") to\n receive [amount] tickets, pulled out of [tx_rollup], to the\n [entrypoint] of the smart contract [destination].\n\n The ticket must have been addressed to the\n claimer, who must be the source of this operation. It must have been\n pulled out at [level] and from the message at [message_index]. The ticket\n is composed of [ticketer; ty; contents]. *)\n | Transfer_ticket : {\n contents : Script_repr.lazy_expr; (** Contents of the withdrawn ticket *)\n ty : Script_repr.lazy_expr;\n (** Type of the withdrawn ticket's contents *)\n ticketer : Contract_repr.t; (** Ticketer of the withdrawn ticket *)\n amount : Ticket_amount.t;\n (** Quantity of the withdrawn ticket. Must match the\n amount that was enabled. *)\n destination : Contract_repr.t;\n (** The smart contract address that should receive the tickets. *)\n entrypoint : Entrypoint_repr.t;\n (** The entrypoint of the smart contract address that should receive the tickets. *)\n }\n -> Kind.transfer_ticket manager_operation\n | Dal_publish_slot_header :\n Dal_slot_repr.Header.operation\n -> Kind.dal_publish_slot_header manager_operation\n (** [Sc_rollup_originate] allows an implicit account to originate a new\n smart contract rollup (initialized with a given boot sector).\n The [parameters_ty] field allows to provide the expected interface\n of the rollup being originated (i.e. its entrypoints with their\n associated signatures) as a Michelson type.\n *)\n | Sc_rollup_originate : {\n kind : Sc_rollups.Kind.t;\n boot_sector : string;\n origination_proof : Sc_rollup_proof_repr.serialized;\n parameters_ty : Script_repr.lazy_expr;\n }\n -> Kind.sc_rollup_originate manager_operation\n (* [Sc_rollup_add_messages] adds messages to the smart rollups' inbox. *)\n | Sc_rollup_add_messages : {\n messages : string list;\n }\n -> Kind.sc_rollup_add_messages manager_operation\n | Sc_rollup_cement : {\n rollup : Sc_rollup_repr.t;\n commitment : Sc_rollup_commitment_repr.Hash.t;\n }\n -> Kind.sc_rollup_cement manager_operation\n | Sc_rollup_publish : {\n rollup : Sc_rollup_repr.t;\n commitment : Sc_rollup_commitment_repr.t;\n }\n -> Kind.sc_rollup_publish manager_operation\n | Sc_rollup_refute : {\n rollup : Sc_rollup_repr.t;\n opponent : Sc_rollup_repr.Staker.t;\n refutation : Sc_rollup_game_repr.refutation;\n }\n -> Kind.sc_rollup_refute manager_operation\n (** [Sc_rollup_refute { rollup; opponent; refutation }] makes a move\n in a refutation game between the source of the operation and the\n [opponent] under the given [rollup]. Both players must be stakers\n on commitments in conflict. When [refutation = None], the game is\n initialized. Next, when [refutation = Some move], [move] is the\n next play for the current player. See {!Sc_rollup_game_repr} for\n details. **)\n | Sc_rollup_timeout : {\n rollup : Sc_rollup_repr.t;\n stakers : Sc_rollup_game_repr.Index.t;\n }\n -> Kind.sc_rollup_timeout manager_operation\n (* [Sc_rollup_execute_outbox_message] executes a message from the rollup's\n outbox. Messages may involve transactions to smart contract accounts on\n Layer 1. *)\n | Sc_rollup_execute_outbox_message : {\n rollup : Sc_rollup_repr.t; (** The smart-contract rollup. *)\n cemented_commitment : Sc_rollup_commitment_repr.Hash.t;\n (** The hash of the last cemented commitment that the proof refers to. *)\n output_proof : string;\n (** A message along with a proof that it is included in the outbox\n at a given outbox level and message index.*)\n }\n -> Kind.sc_rollup_execute_outbox_message manager_operation\n | Sc_rollup_recover_bond : {\n sc_rollup : Sc_rollup_repr.t;\n staker : Signature.Public_key_hash.t;\n }\n -> Kind.sc_rollup_recover_bond manager_operation\n | Zk_rollup_origination : {\n public_parameters : Plonk.public_parameters;\n circuits_info : [`Public | `Private | `Fee] Zk_rollup_account_repr.SMap.t;\n (** Circuit names, alongside a tag indicating its kind. *)\n init_state : Zk_rollup_state_repr.t;\n nb_ops : int;\n }\n -> Kind.zk_rollup_origination manager_operation\n | Zk_rollup_publish : {\n zk_rollup : Zk_rollup_repr.t;\n ops : (Zk_rollup_operation_repr.t * Zk_rollup_ticket_repr.t option) list;\n (* See {!Zk_rollup_apply} *)\n }\n -> Kind.zk_rollup_publish manager_operation\n | Zk_rollup_update : {\n zk_rollup : Zk_rollup_repr.t;\n update : Zk_rollup_update_repr.t;\n }\n -> Kind.zk_rollup_update manager_operation\n\ntype packed_manager_operation =\n | Manager : 'kind manager_operation -> packed_manager_operation\n\ntype packed_contents = Contents : 'kind contents -> packed_contents\n\ntype packed_contents_list =\n | Contents_list : 'kind contents_list -> packed_contents_list\n\nval of_list : packed_contents list -> packed_contents_list tzresult\n\nval to_list : packed_contents_list -> packed_contents list\n\ntype packed_protocol_data =\n | Operation_data : 'kind protocol_data -> packed_protocol_data\n\ntype packed_operation = {\n shell : Operation.shell_header;\n protocol_data : packed_protocol_data;\n}\n\nval pack : 'kind operation -> packed_operation\n\nval manager_kind : 'kind manager_operation -> 'kind Kind.manager\n\nval encoding : packed_operation Data_encoding.t\n\nval contents_encoding : packed_contents Data_encoding.t\n\nval contents_list_encoding : packed_contents_list Data_encoding.t\n\nval protocol_data_encoding : packed_protocol_data Data_encoding.t\n\nval unsigned_operation_encoding :\n (Operation.shell_header * packed_contents_list) Data_encoding.t\n\nval raw : _ operation -> raw\n\nval hash_raw : raw -> Operation_hash.t\n\nval hash : _ operation -> Operation_hash.t\n\nval hash_packed : packed_operation -> Operation_hash.t\n\n(** Each operation belongs to a validation pass that is an integer\n abstracting its priority in a block. Except Failing_noop. *)\n\n(** The validation pass of consensus operations. *)\nval consensus_pass : int\n\n(** The validation pass of voting operations. *)\nval voting_pass : int\n\n(** The validation pass of anonymous operations. *)\nval anonymous_pass : int\n\n(** The validation pass of anonymous operations. *)\nval manager_pass : int\n\n(** [acceptable_pass op] returns either the validation_pass of [op]\n when defines and None when [op] is [Failing_noop]. *)\nval acceptable_pass : packed_operation -> int option\n\n(** [compare_by_passes] orders two operations in the reverse order of\n their acceptable passes. *)\nval compare_by_passes : packed_operation -> packed_operation -> int\n\n(** [compare (oph1,op1) (oph2,op2)] defines a total ordering relation\n on operations.\n\n The following requirements must be satisfied: [oph1] is the\n [Operation.hash op1], [oph2] is [Operation.hash op2], and that\n [op1] and [op2] are valid in the same context.\n\n [compare (oph1,op1) (oph2,op2) = 0] happens only if\n [Operation_hash.compare oph1 oph2 = 0], meaning when [op1] and\n [op2] are structurally identical.\n\n Two valid operations of different [validation_pass] are compared\n according to {!acceptable_passes}: the one with the smaller pass\n being the greater.\n\n Two valid operations of the same [validation_pass] are compared\n according to a [weight], computed thanks to their static\n information.\n\n The global order is as follows:\n\n {!Endorsement} and {!Preendorsement} > {!Dal_attestation} >\n {!Proposals} > {!Ballot} > {!Double_preendorsement_evidence} >\n {!Double_endorsement_evidence} > {!Double_baking_evidence} >\n {!Vdf_revelation} > {!Seed_nonce_revelation} > {!Activate_account}\n > {!Drain_delegate} > {!Manager_operation}.\n\n {!Endorsement} and {!Preendorsement} are compared by the pair of\n their [level] and [round] such as the farther to the current state\n [level] and [round] is greater; e.g. the greater pair in\n lexicographic order being the better. When equal and both\n operations being of the same kind, we compare their [slot]: the\n The smaller being the better, assuming that the more slots an endorser\n has, the smaller is its smallest [slot]. When the pair is equal\n and comparing an {!Endorsement] to a {!Preendorsement}, the\n {!Endorsement} is better.\n\n Two {!Dal_attestation} ops are compared in the lexicographic\n order of the pair of their number of endorsed slots as available\n and their endorsers.\n\n Two voting operations are compared in the lexicographic order of\n the pair of their [period] and [source]. A {!Proposals} is better\n than a {!Ballot}.\n\n Two denunciations of the same kind are compared such as the farther\n to the current state the better. For {!Double_baking_evidence}\n in the case of equality, they are compared by the hashes of their first\n denounced block_header.\n\n Two {!Vdf_revelation} ops are compared by their [solution].\n\n Two {!Seed_nonce_relevation} ops are compared by their [level].\n\n Two {!Activate_account} ops are compared by their [id].\n\n Two {!Drain_delegate} ops are compared by their [delegate].\n\n Two {!Manager_operation}s are compared in the lexicographic order of\n the pair of their [fee]/[gas_limit] ratios and [source]. *)\nval compare :\n Operation_hash.t * packed_operation ->\n Operation_hash.t * packed_operation ->\n int\n\ntype error += Missing_signature (* `Permanent *)\n\ntype error += Invalid_signature (* `Permanent *)\n\nval check_signature :\n Signature.Public_key.t -> Chain_id.t -> _ operation -> unit tzresult\n\ntype ('a, 'b) eq = Eq : ('a, 'a) eq\n\nval equal : 'a operation -> 'b operation -> ('a, 'b) eq option\n\nmodule Encoding : sig\n type 'b case =\n | Case : {\n tag : int;\n name : string;\n encoding : 'a Data_encoding.t;\n select : packed_contents -> 'b contents option;\n proj : 'b contents -> 'a;\n inj : 'a -> 'b contents;\n }\n -> 'b case\n\n val preendorsement_case : Kind.preendorsement case\n\n val endorsement_case : Kind.endorsement case\n\n val dal_attestation_case : Kind.dal_attestation case\n\n val seed_nonce_revelation_case : Kind.seed_nonce_revelation case\n\n val vdf_revelation_case : Kind.vdf_revelation case\n\n val double_preendorsement_evidence_case :\n Kind.double_preendorsement_evidence case\n\n val double_endorsement_evidence_case : Kind.double_endorsement_evidence case\n\n val double_baking_evidence_case : Kind.double_baking_evidence case\n\n val activate_account_case : Kind.activate_account case\n\n val proposals_case : Kind.proposals case\n\n val ballot_case : Kind.ballot case\n\n val drain_delegate_case : Kind.drain_delegate case\n\n val failing_noop_case : Kind.failing_noop case\n\n val reveal_case : Kind.reveal Kind.manager case\n\n val transaction_case : Kind.transaction Kind.manager case\n\n val origination_case : Kind.origination Kind.manager case\n\n val delegation_case : Kind.delegation Kind.manager case\n\n val update_consensus_key_case : Kind.update_consensus_key Kind.manager case\n\n val register_global_constant_case :\n Kind.register_global_constant Kind.manager case\n\n val set_deposits_limit_case : Kind.set_deposits_limit Kind.manager case\n\n val increase_paid_storage_case : Kind.increase_paid_storage Kind.manager case\n\n val tx_rollup_origination_case : Kind.tx_rollup_origination Kind.manager case\n\n val tx_rollup_submit_batch_case :\n Kind.tx_rollup_submit_batch Kind.manager case\n\n val tx_rollup_commit_case : Kind.tx_rollup_commit Kind.manager case\n\n val tx_rollup_return_bond_case : Kind.tx_rollup_return_bond Kind.manager case\n\n val tx_rollup_finalize_commitment_case :\n Kind.tx_rollup_finalize_commitment Kind.manager case\n\n val tx_rollup_remove_commitment_case :\n Kind.tx_rollup_remove_commitment Kind.manager case\n\n val tx_rollup_rejection_case : Kind.tx_rollup_rejection Kind.manager case\n\n val tx_rollup_dispatch_tickets_case :\n Kind.tx_rollup_dispatch_tickets Kind.manager case\n\n val transfer_ticket_case : Kind.transfer_ticket Kind.manager case\n\n val dal_publish_slot_header_case :\n Kind.dal_publish_slot_header Kind.manager case\n\n val sc_rollup_originate_case : Kind.sc_rollup_originate Kind.manager case\n\n val sc_rollup_add_messages_case :\n Kind.sc_rollup_add_messages Kind.manager case\n\n val sc_rollup_cement_case : Kind.sc_rollup_cement Kind.manager case\n\n val sc_rollup_publish_case : Kind.sc_rollup_publish Kind.manager case\n\n val sc_rollup_refute_case : Kind.sc_rollup_refute Kind.manager case\n\n val sc_rollup_timeout_case : Kind.sc_rollup_timeout Kind.manager case\n\n val sc_rollup_execute_outbox_message_case :\n Kind.sc_rollup_execute_outbox_message Kind.manager case\n\n val sc_rollup_recover_bond_case :\n Kind.sc_rollup_recover_bond Kind.manager case\n\n val zk_rollup_origination_case : Kind.zk_rollup_origination Kind.manager case\n\n val zk_rollup_publish_case : Kind.zk_rollup_publish Kind.manager case\n\n val zk_rollup_update_case : Kind.zk_rollup_update Kind.manager case\n\n module Manager_operations : sig\n type 'b case =\n | MCase : {\n tag : int;\n name : string;\n encoding : 'a Data_encoding.t;\n select : packed_manager_operation -> 'kind manager_operation option;\n proj : 'kind manager_operation -> 'a;\n inj : 'a -> 'kind manager_operation;\n }\n -> 'kind case\n\n val reveal_case : Kind.reveal case\n\n val transaction_case : Kind.transaction case\n\n val origination_case : Kind.origination case\n\n val delegation_case : Kind.delegation case\n\n val update_consensus_key_tag : int\n\n val update_consensus_key_case : Kind.update_consensus_key case\n\n val register_global_constant_case : Kind.register_global_constant case\n\n val set_deposits_limit_case : Kind.set_deposits_limit case\n\n val increase_paid_storage_case : Kind.increase_paid_storage case\n\n val tx_rollup_origination_case : Kind.tx_rollup_origination case\n\n val tx_rollup_submit_batch_case : Kind.tx_rollup_submit_batch case\n\n val tx_rollup_commit_case : Kind.tx_rollup_commit case\n\n val tx_rollup_return_bond_case : Kind.tx_rollup_return_bond case\n\n val tx_rollup_finalize_commitment_case :\n Kind.tx_rollup_finalize_commitment case\n\n val tx_rollup_remove_commitment_case : Kind.tx_rollup_remove_commitment case\n\n val tx_rollup_rejection_case : Kind.tx_rollup_rejection case\n\n val tx_rollup_dispatch_tickets_case : Kind.tx_rollup_dispatch_tickets case\n\n val transfer_ticket_case : Kind.transfer_ticket case\n\n val dal_publish_slot_header_case : Kind.dal_publish_slot_header case\n\n val sc_rollup_originate_case : Kind.sc_rollup_originate case\n\n val sc_rollup_add_messages_case : Kind.sc_rollup_add_messages case\n\n val sc_rollup_cement_case : Kind.sc_rollup_cement case\n\n val sc_rollup_publish_case : Kind.sc_rollup_publish case\n\n val sc_rollup_refute_case : Kind.sc_rollup_refute case\n\n val sc_rollup_timeout_case : Kind.sc_rollup_timeout case\n\n val sc_rollup_execute_outbox_message_case :\n Kind.sc_rollup_execute_outbox_message case\n\n val sc_rollup_recover_bond_case : Kind.sc_rollup_recover_bond case\n\n val zk_rollup_origination_case : Kind.zk_rollup_origination case\n\n val zk_rollup_publish_case : Kind.zk_rollup_publish case\n\n val zk_rollup_update_case : Kind.zk_rollup_update case\n end\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(* Tezos Protocol Implementation - Low level Repr. of Operations *)\n\nmodule Kind = struct\n type preendorsement_consensus_kind = Preendorsement_consensus_kind\n\n type endorsement_consensus_kind = Endorsement_consensus_kind\n\n type 'a consensus =\n | Preendorsement_kind : preendorsement_consensus_kind consensus\n | Endorsement_kind : endorsement_consensus_kind consensus\n\n type preendorsement = preendorsement_consensus_kind consensus\n\n type endorsement = endorsement_consensus_kind consensus\n\n type dal_attestation = Dal_attestation_kind\n\n type seed_nonce_revelation = Seed_nonce_revelation_kind\n\n type vdf_revelation = Vdf_revelation_kind\n\n type 'a double_consensus_operation_evidence =\n | Double_consensus_operation_evidence\n\n type double_endorsement_evidence =\n endorsement_consensus_kind double_consensus_operation_evidence\n\n type double_preendorsement_evidence =\n preendorsement_consensus_kind double_consensus_operation_evidence\n\n type double_baking_evidence = Double_baking_evidence_kind\n\n type activate_account = Activate_account_kind\n\n type proposals = Proposals_kind\n\n type ballot = Ballot_kind\n\n type reveal = Reveal_kind\n\n type transaction = Transaction_kind\n\n type origination = Origination_kind\n\n type delegation = Delegation_kind\n\n type event = Event_kind\n\n type set_deposits_limit = Set_deposits_limit_kind\n\n type increase_paid_storage = Increase_paid_storage_kind\n\n type update_consensus_key = Update_consensus_key_kind\n\n type drain_delegate = Drain_delegate_kind\n\n type failing_noop = Failing_noop_kind\n\n type register_global_constant = Register_global_constant_kind\n\n type tx_rollup_origination = Tx_rollup_origination_kind\n\n type tx_rollup_submit_batch = Tx_rollup_submit_batch_kind\n\n type tx_rollup_commit = Tx_rollup_commit_kind\n\n type tx_rollup_return_bond = Tx_rollup_return_bond_kind\n\n type tx_rollup_finalize_commitment = Tx_rollup_finalize_commitment_kind\n\n type tx_rollup_remove_commitment = Tx_rollup_remove_commitment_kind\n\n type tx_rollup_rejection = Tx_rollup_rejection_kind\n\n type tx_rollup_dispatch_tickets = Tx_rollup_dispatch_tickets_kind\n\n type transfer_ticket = Transfer_ticket_kind\n\n type dal_publish_slot_header = Dal_publish_slot_header_kind\n\n type sc_rollup_originate = Sc_rollup_originate_kind\n\n type sc_rollup_add_messages = Sc_rollup_add_messages_kind\n\n type sc_rollup_cement = Sc_rollup_cement_kind\n\n type sc_rollup_publish = Sc_rollup_publish_kind\n\n type sc_rollup_refute = Sc_rollup_refute_kind\n\n type sc_rollup_timeout = Sc_rollup_timeout_kind\n\n type sc_rollup_execute_outbox_message =\n | Sc_rollup_execute_outbox_message_kind\n\n type sc_rollup_recover_bond = Sc_rollup_recover_bond_kind\n\n type zk_rollup_origination = Zk_rollup_origination_kind\n\n type zk_rollup_publish = Zk_rollup_publish_kind\n\n type zk_rollup_update = Zk_rollup_update_kind\n\n type 'a manager =\n | Reveal_manager_kind : reveal manager\n | Transaction_manager_kind : transaction manager\n | Origination_manager_kind : origination manager\n | Delegation_manager_kind : delegation manager\n | Event_manager_kind : event manager\n | Register_global_constant_manager_kind : register_global_constant manager\n | Set_deposits_limit_manager_kind : set_deposits_limit manager\n | Increase_paid_storage_manager_kind : increase_paid_storage manager\n | Update_consensus_key_manager_kind : update_consensus_key manager\n | Tx_rollup_origination_manager_kind : tx_rollup_origination manager\n | Tx_rollup_submit_batch_manager_kind : tx_rollup_submit_batch manager\n | Tx_rollup_commit_manager_kind : tx_rollup_commit manager\n | Tx_rollup_return_bond_manager_kind : tx_rollup_return_bond manager\n | Tx_rollup_finalize_commitment_manager_kind\n : tx_rollup_finalize_commitment manager\n | Tx_rollup_remove_commitment_manager_kind\n : tx_rollup_remove_commitment manager\n | Tx_rollup_rejection_manager_kind : tx_rollup_rejection manager\n | Tx_rollup_dispatch_tickets_manager_kind\n : tx_rollup_dispatch_tickets manager\n | Transfer_ticket_manager_kind : transfer_ticket manager\n | Dal_publish_slot_header_manager_kind : dal_publish_slot_header manager\n | Sc_rollup_originate_manager_kind : sc_rollup_originate manager\n | Sc_rollup_add_messages_manager_kind : sc_rollup_add_messages manager\n | Sc_rollup_cement_manager_kind : sc_rollup_cement manager\n | Sc_rollup_publish_manager_kind : sc_rollup_publish manager\n | Sc_rollup_refute_manager_kind : sc_rollup_refute manager\n | Sc_rollup_timeout_manager_kind : sc_rollup_timeout manager\n | Sc_rollup_execute_outbox_message_manager_kind\n : sc_rollup_execute_outbox_message manager\n | Sc_rollup_recover_bond_manager_kind : sc_rollup_recover_bond manager\n | Zk_rollup_origination_manager_kind : zk_rollup_origination manager\n | Zk_rollup_publish_manager_kind : zk_rollup_publish manager\n | Zk_rollup_update_manager_kind : zk_rollup_update manager\nend\n\ntype 'a consensus_operation_type =\n | Endorsement : Kind.endorsement consensus_operation_type\n | Preendorsement : Kind.preendorsement consensus_operation_type\n\nlet pp_operation_kind (type kind) ppf\n (operation_kind : kind consensus_operation_type) =\n match operation_kind with\n | Endorsement -> Format.fprintf ppf \"Endorsement\"\n | Preendorsement -> Format.fprintf ppf \"Preendorsement\"\n\ntype consensus_content = {\n slot : Slot_repr.t;\n level : Raw_level_repr.t;\n (* The level is not required to validate an endorsement when it corresponds\n to the current payload, but if we want to filter endorsements, we need\n the level. *)\n round : Round_repr.t;\n block_payload_hash : Block_payload_hash.t;\n (* NOTE: This could be just the hash of the set of operations (the\n actual payload). The grandfather block hash should already be\n fixed by the operation.shell.branch field. This is not really\n important but could make things easier for debugging *)\n}\n\nlet consensus_content_encoding =\n let open Data_encoding in\n conv\n (fun {slot; level; round; block_payload_hash} ->\n (slot, level, round, block_payload_hash))\n (fun (slot, level, round, block_payload_hash) ->\n {slot; level; round; block_payload_hash})\n (obj4\n (req \"slot\" Slot_repr.encoding)\n (req \"level\" Raw_level_repr.encoding)\n (req \"round\" Round_repr.encoding)\n (req \"block_payload_hash\" Block_payload_hash.encoding))\n\nlet pp_consensus_content ppf content =\n Format.fprintf\n ppf\n \"(%ld, %a, %a, %a)\"\n (Raw_level_repr.to_int32 content.level)\n Round_repr.pp\n content.round\n Slot_repr.pp\n content.slot\n Block_payload_hash.pp_short\n content.block_payload_hash\n\ntype consensus_watermark =\n | Endorsement of Chain_id.t\n | Preendorsement of Chain_id.t\n | Dal_attestation of Chain_id.t\n\nlet bytes_of_consensus_watermark = function\n | Preendorsement chain_id ->\n Bytes.cat (Bytes.of_string \"\\x12\") (Chain_id.to_bytes chain_id)\n | Dal_attestation chain_id\n (* We reuse the watermark of an endorsement. This is because this\n operation is temporary and aims to be merged with an endorsement\n later on. Moreover, there is a leak of abstraction with the shell\n which makes adding a new watermark a bit awkward. *)\n | Endorsement chain_id ->\n Bytes.cat (Bytes.of_string \"\\x13\") (Chain_id.to_bytes chain_id)\n\nlet to_watermark w = Signature.Custom (bytes_of_consensus_watermark w)\n\nlet of_watermark = function\n | Signature.Custom b ->\n if Compare.Int.(Bytes.length b > 0) then\n match Bytes.get b 0 with\n | '\\x12' ->\n Option.map\n (fun chain_id -> Endorsement chain_id)\n (Chain_id.of_bytes_opt (Bytes.sub b 1 (Bytes.length b - 1)))\n | '\\x13' ->\n Option.map\n (fun chain_id -> Preendorsement chain_id)\n (Chain_id.of_bytes_opt (Bytes.sub b 1 (Bytes.length b - 1)))\n | '\\x14' ->\n Option.map\n (fun chain_id -> Dal_attestation chain_id)\n (Chain_id.of_bytes_opt (Bytes.sub b 1 (Bytes.length b - 1)))\n | _ -> None\n else None\n | _ -> None\n\ntype raw = Operation.t = {shell : Operation.shell_header; proto : bytes}\n\nlet raw_encoding = Operation.encoding\n\ntype 'kind operation = {\n shell : Operation.shell_header;\n protocol_data : 'kind protocol_data;\n}\n\nand 'kind protocol_data = {\n contents : 'kind contents_list;\n signature : Signature.t option;\n}\n\nand _ contents_list =\n | Single : 'kind contents -> 'kind contents_list\n | Cons :\n 'kind Kind.manager contents * 'rest Kind.manager contents_list\n -> ('kind * 'rest) Kind.manager contents_list\n\nand _ contents =\n | Preendorsement : consensus_content -> Kind.preendorsement contents\n | Endorsement : consensus_content -> Kind.endorsement contents\n | Dal_attestation :\n Dal_attestation_repr.operation\n -> Kind.dal_attestation contents\n | Seed_nonce_revelation : {\n level : Raw_level_repr.t;\n nonce : Seed_repr.nonce;\n }\n -> Kind.seed_nonce_revelation contents\n | Vdf_revelation : {\n solution : Seed_repr.vdf_solution;\n }\n -> Kind.vdf_revelation contents\n | Double_preendorsement_evidence : {\n op1 : Kind.preendorsement operation;\n op2 : Kind.preendorsement operation;\n }\n -> Kind.double_preendorsement_evidence contents\n | Double_endorsement_evidence : {\n op1 : Kind.endorsement operation;\n op2 : Kind.endorsement operation;\n }\n -> Kind.double_endorsement_evidence contents\n | Double_baking_evidence : {\n bh1 : Block_header_repr.t;\n bh2 : Block_header_repr.t;\n }\n -> Kind.double_baking_evidence contents\n | Activate_account : {\n id : Ed25519.Public_key_hash.t;\n activation_code : Blinded_public_key_hash.activation_code;\n }\n -> Kind.activate_account contents\n | Proposals : {\n source : Signature.Public_key_hash.t;\n period : int32;\n proposals : Protocol_hash.t list;\n }\n -> Kind.proposals contents\n | Ballot : {\n source : Signature.Public_key_hash.t;\n period : int32;\n proposal : Protocol_hash.t;\n ballot : Vote_repr.ballot;\n }\n -> Kind.ballot contents\n | Drain_delegate : {\n consensus_key : Signature.Public_key_hash.t;\n delegate : Signature.Public_key_hash.t;\n destination : Signature.Public_key_hash.t;\n }\n -> Kind.drain_delegate contents\n | Failing_noop : string -> Kind.failing_noop contents\n | Manager_operation : {\n source : Signature.public_key_hash;\n fee : Tez_repr.tez;\n counter : Manager_counter_repr.t;\n operation : 'kind manager_operation;\n gas_limit : Gas_limit_repr.Arith.integral;\n storage_limit : Z.t;\n }\n -> 'kind Kind.manager contents\n\nand _ manager_operation =\n | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation\n | Transaction : {\n amount : Tez_repr.tez;\n parameters : Script_repr.lazy_expr;\n entrypoint : Entrypoint_repr.t;\n destination : Contract_repr.t;\n }\n -> Kind.transaction manager_operation\n | Origination : {\n delegate : Signature.Public_key_hash.t option;\n script : Script_repr.t;\n credit : Tez_repr.tez;\n }\n -> Kind.origination manager_operation\n | Delegation :\n Signature.Public_key_hash.t option\n -> Kind.delegation manager_operation\n | Register_global_constant : {\n value : Script_repr.lazy_expr;\n }\n -> Kind.register_global_constant manager_operation\n | Set_deposits_limit :\n Tez_repr.t option\n -> Kind.set_deposits_limit manager_operation\n | Increase_paid_storage : {\n amount_in_bytes : Z.t;\n destination : Contract_hash.t;\n }\n -> Kind.increase_paid_storage manager_operation\n | Update_consensus_key :\n Signature.Public_key.t\n -> Kind.update_consensus_key manager_operation\n | Tx_rollup_origination : Kind.tx_rollup_origination manager_operation\n | Tx_rollup_submit_batch : {\n tx_rollup : Tx_rollup_repr.t;\n content : string;\n burn_limit : Tez_repr.t option;\n }\n -> Kind.tx_rollup_submit_batch manager_operation\n | Tx_rollup_commit : {\n tx_rollup : Tx_rollup_repr.t;\n commitment : Tx_rollup_commitment_repr.Full.t;\n }\n -> Kind.tx_rollup_commit manager_operation\n | Tx_rollup_return_bond : {\n tx_rollup : Tx_rollup_repr.t;\n }\n -> Kind.tx_rollup_return_bond manager_operation\n | Tx_rollup_finalize_commitment : {\n tx_rollup : Tx_rollup_repr.t;\n }\n -> Kind.tx_rollup_finalize_commitment manager_operation\n | Tx_rollup_remove_commitment : {\n tx_rollup : Tx_rollup_repr.t;\n }\n -> Kind.tx_rollup_remove_commitment manager_operation\n | Tx_rollup_rejection : {\n tx_rollup : Tx_rollup_repr.t;\n level : Tx_rollup_level_repr.t;\n message : Tx_rollup_message_repr.t;\n message_position : int;\n message_path : Tx_rollup_inbox_repr.Merkle.path;\n message_result_hash : Tx_rollup_message_result_hash_repr.t;\n message_result_path : Tx_rollup_commitment_repr.Merkle.path;\n previous_message_result : Tx_rollup_message_result_repr.t;\n previous_message_result_path : Tx_rollup_commitment_repr.Merkle.path;\n proof : Tx_rollup_l2_proof.serialized;\n }\n -> Kind.tx_rollup_rejection manager_operation\n | Tx_rollup_dispatch_tickets : {\n tx_rollup : Tx_rollup_repr.t;\n level : Tx_rollup_level_repr.t;\n context_hash : Context_hash.t;\n message_index : int;\n message_result_path : Tx_rollup_commitment_repr.Merkle.path;\n tickets_info : Tx_rollup_reveal_repr.t list;\n }\n -> Kind.tx_rollup_dispatch_tickets manager_operation\n | Transfer_ticket : {\n contents : Script_repr.lazy_expr;\n ty : Script_repr.lazy_expr;\n ticketer : Contract_repr.t;\n amount : Ticket_amount.t;\n destination : Contract_repr.t;\n entrypoint : Entrypoint_repr.t;\n }\n -> Kind.transfer_ticket manager_operation\n | Dal_publish_slot_header :\n Dal_slot_repr.Header.operation\n -> Kind.dal_publish_slot_header manager_operation\n | Sc_rollup_originate : {\n kind : Sc_rollups.Kind.t;\n boot_sector : string;\n origination_proof : Sc_rollup_proof_repr.serialized;\n parameters_ty : Script_repr.lazy_expr;\n }\n -> Kind.sc_rollup_originate manager_operation\n | Sc_rollup_add_messages : {\n messages : string list;\n }\n -> Kind.sc_rollup_add_messages manager_operation\n | Sc_rollup_cement : {\n rollup : Sc_rollup_repr.t;\n commitment : Sc_rollup_commitment_repr.Hash.t;\n }\n -> Kind.sc_rollup_cement manager_operation\n | Sc_rollup_publish : {\n rollup : Sc_rollup_repr.t;\n commitment : Sc_rollup_commitment_repr.t;\n }\n -> Kind.sc_rollup_publish manager_operation\n | Sc_rollup_refute : {\n rollup : Sc_rollup_repr.t;\n opponent : Sc_rollup_repr.Staker.t;\n refutation : Sc_rollup_game_repr.refutation;\n }\n -> Kind.sc_rollup_refute manager_operation\n | Sc_rollup_timeout : {\n rollup : Sc_rollup_repr.t;\n stakers : Sc_rollup_game_repr.Index.t;\n }\n -> Kind.sc_rollup_timeout manager_operation\n | Sc_rollup_execute_outbox_message : {\n rollup : Sc_rollup_repr.t;\n cemented_commitment : Sc_rollup_commitment_repr.Hash.t;\n output_proof : string;\n }\n -> Kind.sc_rollup_execute_outbox_message manager_operation\n | Sc_rollup_recover_bond : {\n sc_rollup : Sc_rollup_repr.t;\n staker : Signature.public_key_hash;\n }\n -> Kind.sc_rollup_recover_bond manager_operation\n | Zk_rollup_origination : {\n public_parameters : Plonk.public_parameters;\n circuits_info : [`Public | `Private | `Fee] Zk_rollup_account_repr.SMap.t;\n init_state : Zk_rollup_state_repr.t;\n nb_ops : int;\n }\n -> Kind.zk_rollup_origination manager_operation\n | Zk_rollup_publish : {\n zk_rollup : Zk_rollup_repr.t;\n ops : (Zk_rollup_operation_repr.t * Zk_rollup_ticket_repr.t option) list;\n }\n -> Kind.zk_rollup_publish manager_operation\n | Zk_rollup_update : {\n zk_rollup : Zk_rollup_repr.t;\n update : Zk_rollup_update_repr.t;\n }\n -> Kind.zk_rollup_update manager_operation\n\nlet manager_kind : type kind. kind manager_operation -> kind Kind.manager =\n function\n | Reveal _ -> Kind.Reveal_manager_kind\n | Transaction _ -> Kind.Transaction_manager_kind\n | Origination _ -> Kind.Origination_manager_kind\n | Delegation _ -> Kind.Delegation_manager_kind\n | Register_global_constant _ -> Kind.Register_global_constant_manager_kind\n | Set_deposits_limit _ -> Kind.Set_deposits_limit_manager_kind\n | Increase_paid_storage _ -> Kind.Increase_paid_storage_manager_kind\n | Update_consensus_key _ -> Kind.Update_consensus_key_manager_kind\n | Tx_rollup_origination -> Kind.Tx_rollup_origination_manager_kind\n | Tx_rollup_submit_batch _ -> Kind.Tx_rollup_submit_batch_manager_kind\n | Tx_rollup_commit _ -> Kind.Tx_rollup_commit_manager_kind\n | Tx_rollup_return_bond _ -> Kind.Tx_rollup_return_bond_manager_kind\n | Tx_rollup_finalize_commitment _ ->\n Kind.Tx_rollup_finalize_commitment_manager_kind\n | Tx_rollup_remove_commitment _ ->\n Kind.Tx_rollup_remove_commitment_manager_kind\n | Tx_rollup_rejection _ -> Kind.Tx_rollup_rejection_manager_kind\n | Tx_rollup_dispatch_tickets _ -> Kind.Tx_rollup_dispatch_tickets_manager_kind\n | Transfer_ticket _ -> Kind.Transfer_ticket_manager_kind\n | Dal_publish_slot_header _ -> Kind.Dal_publish_slot_header_manager_kind\n | Sc_rollup_originate _ -> Kind.Sc_rollup_originate_manager_kind\n | Sc_rollup_add_messages _ -> Kind.Sc_rollup_add_messages_manager_kind\n | Sc_rollup_cement _ -> Kind.Sc_rollup_cement_manager_kind\n | Sc_rollup_publish _ -> Kind.Sc_rollup_publish_manager_kind\n | Sc_rollup_refute _ -> Kind.Sc_rollup_refute_manager_kind\n | Sc_rollup_timeout _ -> Kind.Sc_rollup_timeout_manager_kind\n | Sc_rollup_execute_outbox_message _ ->\n Kind.Sc_rollup_execute_outbox_message_manager_kind\n | Sc_rollup_recover_bond _ -> Kind.Sc_rollup_recover_bond_manager_kind\n | Zk_rollup_origination _ -> Kind.Zk_rollup_origination_manager_kind\n | Zk_rollup_publish _ -> Kind.Zk_rollup_publish_manager_kind\n | Zk_rollup_update _ -> Kind.Zk_rollup_update_manager_kind\n\ntype packed_manager_operation =\n | Manager : 'kind manager_operation -> packed_manager_operation\n\ntype packed_contents = Contents : 'kind contents -> packed_contents\n\ntype packed_contents_list =\n | Contents_list : 'kind contents_list -> packed_contents_list\n\ntype packed_protocol_data =\n | Operation_data : 'kind protocol_data -> packed_protocol_data\n\ntype packed_operation = {\n shell : Operation.shell_header;\n protocol_data : packed_protocol_data;\n}\n\nlet pack ({shell; protocol_data} : _ operation) : packed_operation =\n {shell; protocol_data = Operation_data protocol_data}\n\nlet rec contents_list_to_list : type a. a contents_list -> _ = function\n | Single o -> [Contents o]\n | Cons (o, os) -> Contents o :: contents_list_to_list os\n\nlet to_list = function Contents_list l -> contents_list_to_list l\n\n(* This first version of of_list has the type (_, string) result expected by\n the conv_with_guard combinator of Data_encoding. For a more conventional\n return type see [of_list] below. *)\nlet of_list_internal contents =\n let rec of_list_internal acc = function\n | [] -> Ok acc\n | Contents o :: os -> (\n match (o, acc) with\n | ( Manager_operation _,\n Contents_list (Single (Manager_operation _) as rest) ) ->\n (of_list_internal [@tailcall]) (Contents_list (Cons (o, rest))) os\n | Manager_operation _, Contents_list (Cons _ as rest) ->\n (of_list_internal [@tailcall]) (Contents_list (Cons (o, rest))) os\n | _ ->\n Error\n \"Operation list of length > 1 should only contain manager \\\n operations.\")\n in\n match List.rev contents with\n | [] -> Error \"Operation lists should not be empty.\"\n | Contents o :: os -> of_list_internal (Contents_list (Single o)) os\n\ntype error += Contents_list_error of string (* `Permanent *)\n\nlet of_list l =\n match of_list_internal l with\n | Ok contents -> Ok contents\n | Error s -> error @@ Contents_list_error s\n\nlet tx_rollup_operation_tag_offset = 150\n\nlet tx_rollup_operation_origination_tag = tx_rollup_operation_tag_offset + 0\n\nlet tx_rollup_operation_submit_batch_tag = tx_rollup_operation_tag_offset + 1\n\nlet tx_rollup_operation_commit_tag = tx_rollup_operation_tag_offset + 2\n\nlet tx_rollup_operation_return_bond_tag = tx_rollup_operation_tag_offset + 3\n\nlet tx_rollup_operation_finalize_commitment_tag =\n tx_rollup_operation_tag_offset + 4\n\nlet tx_rollup_operation_remove_commitment_tag =\n tx_rollup_operation_tag_offset + 5\n\nlet tx_rollup_operation_rejection_tag = tx_rollup_operation_tag_offset + 6\n\nlet tx_rollup_operation_dispatch_tickets_tag =\n tx_rollup_operation_tag_offset + 7\n\nlet transfer_ticket_tag = tx_rollup_operation_tag_offset + 8\n\nlet sc_rollup_operation_tag_offset = 200\n\nlet sc_rollup_operation_origination_tag = sc_rollup_operation_tag_offset + 0\n\nlet sc_rollup_operation_add_message_tag = sc_rollup_operation_tag_offset + 1\n\nlet sc_rollup_operation_cement_tag = sc_rollup_operation_tag_offset + 2\n\nlet sc_rollup_operation_publish_tag = sc_rollup_operation_tag_offset + 3\n\nlet sc_rollup_operation_refute_tag = sc_rollup_operation_tag_offset + 4\n\nlet sc_rollup_operation_timeout_tag = sc_rollup_operation_tag_offset + 5\n\nlet sc_rollup_execute_outbox_message_tag = sc_rollup_operation_tag_offset + 6\n\nlet sc_rollup_operation_recover_bond_tag = sc_rollup_operation_tag_offset + 7\n\nlet dal_offset = 230\n\nlet dal_publish_slot_header_tag = dal_offset + 0\n\nlet zk_rollup_operation_tag_offset = 250\n\nlet zk_rollup_operation_create_tag = zk_rollup_operation_tag_offset + 0\n\nlet zk_rollup_operation_publish_tag = zk_rollup_operation_tag_offset + 1\n\nlet zk_rollup_operation_update_tag = zk_rollup_operation_tag_offset + 2\n\nmodule Encoding = struct\n open Data_encoding\n\n (** These tags are reserved for future extensions: [fd] - [ff]. *)\n let reserved_tag t = Compare.Int.(t >= 0xfd)\n\n let signature_prefix_tag = 0xff\n\n let () = assert (reserved_tag signature_prefix_tag)\n\n let case tag name args proj inj =\n case\n tag\n ~title:(String.capitalize_ascii name)\n (merge_objs (obj1 (req \"kind\" (constant name))) args)\n (fun x -> match proj x with None -> None | Some x -> Some ((), x))\n (fun ((), x) -> inj x)\n\n module Manager_operations = struct\n type 'kind case =\n | MCase : {\n tag : int;\n name : string;\n encoding : 'a Data_encoding.t;\n select : packed_manager_operation -> 'kind manager_operation option;\n proj : 'kind manager_operation -> 'a;\n inj : 'a -> 'kind manager_operation;\n }\n -> 'kind case\n\n let reveal_case =\n MCase\n {\n tag = 0;\n name = \"reveal\";\n encoding = obj1 (req \"public_key\" Signature.Public_key.encoding);\n select = (function Manager (Reveal _ as op) -> Some op | _ -> None);\n proj = (function Reveal pkh -> pkh);\n inj = (fun pkh -> Reveal pkh);\n }\n\n let transaction_case =\n MCase\n {\n tag = 1;\n name = \"transaction\";\n encoding =\n obj3\n (req \"amount\" Tez_repr.encoding)\n (req \"destination\" Contract_repr.encoding)\n (opt\n \"parameters\"\n (obj2\n (req \"entrypoint\" Entrypoint_repr.smart_encoding)\n (req \"value\" Script_repr.lazy_expr_encoding)));\n select =\n (function Manager (Transaction _ as op) -> Some op | _ -> None);\n proj =\n (function\n | Transaction {amount; destination; parameters; entrypoint} ->\n let parameters =\n if\n Script_repr.is_unit_parameter parameters\n && Entrypoint_repr.is_default entrypoint\n then None\n else Some (entrypoint, parameters)\n in\n (amount, destination, parameters));\n inj =\n (fun (amount, destination, parameters) ->\n let entrypoint, parameters =\n match parameters with\n | None -> (Entrypoint_repr.default, Script_repr.unit_parameter)\n | Some (entrypoint, value) -> (entrypoint, value)\n in\n Transaction {amount; destination; parameters; entrypoint});\n }\n\n let origination_case =\n MCase\n {\n tag = 2;\n name = \"origination\";\n encoding =\n obj3\n (req \"balance\" Tez_repr.encoding)\n (opt \"delegate\" Signature.Public_key_hash.encoding)\n (req \"script\" Script_repr.encoding);\n select =\n (function Manager (Origination _ as op) -> Some op | _ -> None);\n proj =\n (function\n | Origination {credit; delegate; script} ->\n (credit, delegate, script));\n inj =\n (fun (credit, delegate, script) ->\n Origination {credit; delegate; script});\n }\n\n let delegation_case =\n MCase\n {\n tag = 3;\n name = \"delegation\";\n encoding = obj1 (opt \"delegate\" Signature.Public_key_hash.encoding);\n select =\n (function Manager (Delegation _ as op) -> Some op | _ -> None);\n proj = (function Delegation key -> key);\n inj = (fun key -> Delegation key);\n }\n\n let register_global_constant_case =\n MCase\n {\n tag = 4;\n name = \"register_global_constant\";\n encoding = obj1 (req \"value\" Script_repr.lazy_expr_encoding);\n select =\n (function\n | Manager (Register_global_constant _ as op) -> Some op | _ -> None);\n proj = (function Register_global_constant {value} -> value);\n inj = (fun value -> Register_global_constant {value});\n }\n\n let set_deposits_limit_case =\n MCase\n {\n tag = 5;\n name = \"set_deposits_limit\";\n encoding = obj1 (opt \"limit\" Tez_repr.encoding);\n select =\n (function\n | Manager (Set_deposits_limit _ as op) -> Some op | _ -> None);\n proj = (function Set_deposits_limit key -> key);\n inj = (fun key -> Set_deposits_limit key);\n }\n\n let increase_paid_storage_case =\n MCase\n {\n tag = 9;\n name = \"increase_paid_storage\";\n encoding =\n obj2\n (req \"amount\" Data_encoding.z)\n (req \"destination\" Contract_repr.originated_encoding);\n select =\n (function\n | Manager (Increase_paid_storage _ as op) -> Some op | _ -> None);\n proj =\n (function\n | Increase_paid_storage {amount_in_bytes; destination} ->\n (amount_in_bytes, destination));\n inj =\n (fun (amount_in_bytes, destination) ->\n Increase_paid_storage {amount_in_bytes; destination});\n }\n\n let update_consensus_key_tag = 6\n\n let update_consensus_key_case =\n MCase\n {\n tag = update_consensus_key_tag;\n name = \"update_consensus_key\";\n encoding = obj1 (req \"pk\" Signature.Public_key.encoding);\n select =\n (function\n | Manager (Update_consensus_key _ as op) -> Some op | _ -> None);\n proj = (function Update_consensus_key consensus_pk -> consensus_pk);\n inj = (fun consensus_pk -> Update_consensus_key consensus_pk);\n }\n\n let tx_rollup_origination_case =\n MCase\n {\n tag = tx_rollup_operation_origination_tag;\n name = \"tx_rollup_origination\";\n encoding = obj1 (req \"tx_rollup_origination\" Data_encoding.unit);\n select =\n (function\n | Manager (Tx_rollup_origination as op) -> Some op | _ -> None);\n proj = (function Tx_rollup_origination -> ());\n inj = (fun () -> Tx_rollup_origination);\n }\n\n let tx_rollup_submit_batch_case =\n MCase\n {\n tag = tx_rollup_operation_submit_batch_tag;\n name = \"tx_rollup_submit_batch\";\n encoding =\n obj3\n (req \"rollup\" Tx_rollup_repr.encoding)\n (req \"content\" (string Hex))\n (opt \"burn_limit\" Tez_repr.encoding);\n select =\n (function\n | Manager (Tx_rollup_submit_batch _ as op) -> Some op | _ -> None);\n proj =\n (function\n | Tx_rollup_submit_batch {tx_rollup; content; burn_limit} ->\n (tx_rollup, content, burn_limit));\n inj =\n (fun (tx_rollup, content, burn_limit) ->\n Tx_rollup_submit_batch {tx_rollup; content; burn_limit});\n }\n\n let tx_rollup_commit_case =\n MCase\n {\n tag = tx_rollup_operation_commit_tag;\n name = \"tx_rollup_commit\";\n encoding =\n obj2\n (req \"rollup\" Tx_rollup_repr.encoding)\n (req \"commitment\" Tx_rollup_commitment_repr.Full.encoding);\n select =\n (function\n | Manager (Tx_rollup_commit _ as op) -> Some op | _ -> None);\n proj =\n (function\n | Tx_rollup_commit {tx_rollup; commitment} -> (tx_rollup, commitment));\n inj =\n (fun (tx_rollup, commitment) ->\n Tx_rollup_commit {tx_rollup; commitment});\n }\n\n let tx_rollup_return_bond_case =\n MCase\n {\n tag = tx_rollup_operation_return_bond_tag;\n name = \"tx_rollup_return_bond\";\n encoding = obj1 (req \"rollup\" Tx_rollup_repr.encoding);\n select =\n (function\n | Manager (Tx_rollup_return_bond _ as op) -> Some op | _ -> None);\n proj = (function Tx_rollup_return_bond {tx_rollup} -> tx_rollup);\n inj = (fun tx_rollup -> Tx_rollup_return_bond {tx_rollup});\n }\n\n let tx_rollup_finalize_commitment_case =\n MCase\n {\n tag = tx_rollup_operation_finalize_commitment_tag;\n name = \"tx_rollup_finalize_commitment\";\n encoding = obj1 (req \"rollup\" Tx_rollup_repr.encoding);\n select =\n (function\n | Manager (Tx_rollup_finalize_commitment _ as op) -> Some op\n | _ -> None);\n proj =\n (function Tx_rollup_finalize_commitment {tx_rollup} -> tx_rollup);\n inj = (fun tx_rollup -> Tx_rollup_finalize_commitment {tx_rollup});\n }\n\n let tx_rollup_remove_commitment_case =\n MCase\n {\n tag = tx_rollup_operation_remove_commitment_tag;\n name = \"tx_rollup_remove_commitment\";\n encoding = obj1 (req \"rollup\" Tx_rollup_repr.encoding);\n select =\n (function\n | Manager (Tx_rollup_remove_commitment _ as op) -> Some op\n | _ -> None);\n proj =\n (function Tx_rollup_remove_commitment {tx_rollup} -> tx_rollup);\n inj = (fun tx_rollup -> Tx_rollup_remove_commitment {tx_rollup});\n }\n\n let tx_rollup_rejection_case =\n MCase\n {\n tag = tx_rollup_operation_rejection_tag;\n name = \"tx_rollup_rejection\";\n encoding =\n obj10\n (req \"rollup\" Tx_rollup_repr.encoding)\n (req \"level\" Tx_rollup_level_repr.encoding)\n (req \"message\" Tx_rollup_message_repr.encoding)\n (req \"message_position\" n)\n (req \"message_path\" Tx_rollup_inbox_repr.Merkle.path_encoding)\n (req\n \"message_result_hash\"\n Tx_rollup_message_result_hash_repr.encoding)\n (req\n \"message_result_path\"\n Tx_rollup_commitment_repr.Merkle.path_encoding)\n (req\n \"previous_message_result\"\n Tx_rollup_message_result_repr.encoding)\n (req\n \"previous_message_result_path\"\n Tx_rollup_commitment_repr.Merkle.path_encoding)\n (req \"proof\" Tx_rollup_l2_proof.serialized_encoding);\n select =\n (function\n | Manager (Tx_rollup_rejection _ as op) -> Some op | _ -> None);\n proj =\n (function\n | Tx_rollup_rejection\n {\n tx_rollup;\n level;\n message;\n message_position;\n message_path;\n message_result_hash;\n message_result_path;\n previous_message_result;\n previous_message_result_path;\n proof;\n } ->\n ( tx_rollup,\n level,\n message,\n Z.of_int message_position,\n message_path,\n message_result_hash,\n message_result_path,\n previous_message_result,\n previous_message_result_path,\n proof ));\n inj =\n (fun ( tx_rollup,\n level,\n message,\n message_position,\n message_path,\n message_result_hash,\n message_result_path,\n previous_message_result,\n previous_message_result_path,\n proof ) ->\n Tx_rollup_rejection\n {\n tx_rollup;\n level;\n message;\n message_position = Z.to_int message_position;\n message_path;\n message_result_hash;\n message_result_path;\n previous_message_result;\n previous_message_result_path;\n proof;\n });\n }\n\n let tx_rollup_dispatch_tickets_case =\n MCase\n {\n tag = tx_rollup_operation_dispatch_tickets_tag;\n name = \"tx_rollup_dispatch_tickets\";\n encoding =\n obj6\n (req \"tx_rollup\" Tx_rollup_repr.encoding)\n (req \"level\" Tx_rollup_level_repr.encoding)\n (req \"context_hash\" Context_hash.encoding)\n (req \"message_index\" int31)\n (req\n \"message_result_path\"\n Tx_rollup_commitment_repr.Merkle.path_encoding)\n (req\n \"tickets_info\"\n (Data_encoding.list Tx_rollup_reveal_repr.encoding));\n select =\n (function\n | Manager (Tx_rollup_dispatch_tickets _ as op) -> Some op\n | _ -> None);\n proj =\n (function\n | Tx_rollup_dispatch_tickets\n {\n tx_rollup;\n level;\n context_hash;\n message_index;\n message_result_path;\n tickets_info;\n } ->\n ( tx_rollup,\n level,\n context_hash,\n message_index,\n message_result_path,\n tickets_info ));\n inj =\n (fun ( tx_rollup,\n level,\n context_hash,\n message_index,\n message_result_path,\n tickets_info ) ->\n Tx_rollup_dispatch_tickets\n {\n tx_rollup;\n level;\n context_hash;\n message_index;\n message_result_path;\n tickets_info;\n });\n }\n\n let transfer_ticket_case =\n MCase\n {\n tag = transfer_ticket_tag;\n name = \"transfer_ticket\";\n encoding =\n obj6\n (req \"ticket_contents\" Script_repr.lazy_expr_encoding)\n (req \"ticket_ty\" Script_repr.lazy_expr_encoding)\n (req \"ticket_ticketer\" Contract_repr.encoding)\n (req \"ticket_amount\" Ticket_amount.encoding)\n (req \"destination\" Contract_repr.encoding)\n (req \"entrypoint\" Entrypoint_repr.simple_encoding);\n select =\n (function\n | Manager (Transfer_ticket _ as op) -> Some op | _ -> None);\n proj =\n (function\n | Transfer_ticket\n {contents; ty; ticketer; amount; destination; entrypoint} ->\n (contents, ty, ticketer, amount, destination, entrypoint));\n inj =\n (fun (contents, ty, ticketer, amount, destination, entrypoint) ->\n Transfer_ticket\n {contents; ty; ticketer; amount; destination; entrypoint});\n }\n\n let zk_rollup_origination_case =\n MCase\n {\n tag = zk_rollup_operation_create_tag;\n name = \"zk_rollup_origination\";\n encoding =\n obj4\n (req \"public_parameters\" Plonk.public_parameters_encoding)\n (req\n \"circuits_info\"\n Zk_rollup_account_repr.circuits_info_encoding)\n (req \"init_state\" Zk_rollup_state_repr.encoding)\n (* TODO https://gitlab.com/tezos/tezos/-/issues/3655\n Encoding of non-negative [nb_ops] for origination *)\n (req \"nb_ops\" int31);\n select =\n (function\n | Manager (Zk_rollup_origination _ as op) -> Some op | _ -> None);\n proj =\n (function\n | Zk_rollup_origination\n {public_parameters; circuits_info; init_state; nb_ops} ->\n (public_parameters, circuits_info, init_state, nb_ops));\n inj =\n (fun (public_parameters, circuits_info, init_state, nb_ops) ->\n Zk_rollup_origination\n {public_parameters; circuits_info; init_state; nb_ops});\n }\n\n let zk_rollup_publish_case =\n MCase\n {\n tag = zk_rollup_operation_publish_tag;\n name = \"zk_rollup_publish\";\n encoding =\n obj2\n (req \"zk_rollup\" Zk_rollup_repr.Address.encoding)\n (req \"op\"\n @@ Data_encoding.list\n (tup2\n Zk_rollup_operation_repr.encoding\n (option Zk_rollup_ticket_repr.encoding)));\n select =\n (function\n | Manager (Zk_rollup_publish _ as op) -> Some op | _ -> None);\n proj =\n (function Zk_rollup_publish {zk_rollup; ops} -> (zk_rollup, ops));\n inj = (fun (zk_rollup, ops) -> Zk_rollup_publish {zk_rollup; ops});\n }\n\n let zk_rollup_update_case =\n MCase\n {\n tag = zk_rollup_operation_update_tag;\n name = \"zk_rollup_update\";\n encoding =\n obj2\n (req \"zk_rollup\" Zk_rollup_repr.Address.encoding)\n (req \"update\" Zk_rollup_update_repr.encoding);\n select =\n (function\n | Manager (Zk_rollup_update _ as op) -> Some op | _ -> None);\n proj =\n (function\n | Zk_rollup_update {zk_rollup; update} -> (zk_rollup, update));\n inj =\n (fun (zk_rollup, update) -> Zk_rollup_update {zk_rollup; update});\n }\n\n let sc_rollup_originate_case =\n MCase\n {\n tag = sc_rollup_operation_origination_tag;\n name = \"smart_rollup_originate\";\n encoding =\n obj4\n (req \"pvm_kind\" Sc_rollups.Kind.encoding)\n (req \"kernel\" (string Hex))\n (req \"origination_proof\" Sc_rollup_proof_repr.serialized_encoding)\n (req \"parameters_ty\" Script_repr.lazy_expr_encoding);\n select =\n (function\n | Manager (Sc_rollup_originate _ as op) -> Some op | _ -> None);\n proj =\n (function\n | Sc_rollup_originate\n {kind; boot_sector; origination_proof; parameters_ty} ->\n (kind, boot_sector, origination_proof, parameters_ty));\n inj =\n (fun (kind, boot_sector, origination_proof, parameters_ty) ->\n Sc_rollup_originate\n {kind; boot_sector; origination_proof; parameters_ty});\n }\n\n let dal_publish_slot_header_case =\n MCase\n {\n tag = dal_publish_slot_header_tag;\n name = \"dal_publish_slot_header\";\n encoding =\n obj1 (req \"slot_header\" Dal_slot_repr.Header.operation_encoding);\n select =\n (function\n | Manager (Dal_publish_slot_header _ as op) -> Some op | _ -> None);\n proj = (function Dal_publish_slot_header slot_header -> slot_header);\n inj = (fun slot_header -> Dal_publish_slot_header slot_header);\n }\n\n let sc_rollup_add_messages_case =\n MCase\n {\n tag = sc_rollup_operation_add_message_tag;\n name = \"smart_rollup_add_messages\";\n encoding = obj1 (req \"message\" (list (string Hex)));\n select =\n (function\n | Manager (Sc_rollup_add_messages _ as op) -> Some op | _ -> None);\n proj = (function Sc_rollup_add_messages {messages} -> messages);\n inj = (fun messages -> Sc_rollup_add_messages {messages});\n }\n\n let sc_rollup_cement_case =\n MCase\n {\n tag = sc_rollup_operation_cement_tag;\n name = \"smart_rollup_cement\";\n encoding =\n obj2\n (req \"rollup\" Sc_rollup_repr.encoding)\n (req \"commitment\" Sc_rollup_commitment_repr.Hash.encoding);\n select =\n (function\n | Manager (Sc_rollup_cement _ as op) -> Some op | _ -> None);\n proj =\n (function\n | Sc_rollup_cement {rollup; commitment} -> (rollup, commitment));\n inj =\n (fun (rollup, commitment) -> Sc_rollup_cement {rollup; commitment});\n }\n\n let sc_rollup_publish_case =\n MCase\n {\n tag = sc_rollup_operation_publish_tag;\n name = \"smart_rollup_publish\";\n encoding =\n obj2\n (req \"rollup\" Sc_rollup_repr.encoding)\n (req \"commitment\" Sc_rollup_commitment_repr.encoding);\n select =\n (function\n | Manager (Sc_rollup_publish _ as op) -> Some op | _ -> None);\n proj =\n (function\n | Sc_rollup_publish {rollup; commitment} -> (rollup, commitment));\n inj =\n (fun (rollup, commitment) -> Sc_rollup_publish {rollup; commitment});\n }\n\n let sc_rollup_refute_case =\n MCase\n {\n tag = sc_rollup_operation_refute_tag;\n name = \"smart_rollup_refute\";\n encoding =\n obj3\n (req \"rollup\" Sc_rollup_repr.encoding)\n (req \"opponent\" Sc_rollup_repr.Staker.encoding)\n (req \"refutation\" Sc_rollup_game_repr.refutation_encoding);\n select =\n (function\n | Manager (Sc_rollup_refute _ as op) -> Some op | _ -> None);\n proj =\n (function\n | Sc_rollup_refute {rollup; opponent; refutation} ->\n (rollup, opponent, refutation));\n inj =\n (fun (rollup, opponent, refutation) ->\n Sc_rollup_refute {rollup; opponent; refutation});\n }\n\n let sc_rollup_timeout_case =\n MCase\n {\n tag = sc_rollup_operation_timeout_tag;\n name = \"smart_rollup_timeout\";\n encoding =\n obj2\n (req \"rollup\" Sc_rollup_repr.encoding)\n (req \"stakers\" Sc_rollup_game_repr.Index.encoding);\n select =\n (function\n | Manager (Sc_rollup_timeout _ as op) -> Some op | _ -> None);\n proj =\n (function\n | Sc_rollup_timeout {rollup; stakers} -> (rollup, stakers));\n inj = (fun (rollup, stakers) -> Sc_rollup_timeout {rollup; stakers});\n }\n\n let sc_rollup_execute_outbox_message_case =\n MCase\n {\n tag = sc_rollup_execute_outbox_message_tag;\n name = \"smart_rollup_execute_outbox_message\";\n encoding =\n obj3\n (req \"rollup\" Sc_rollup_repr.encoding)\n (req\n \"cemented_commitment\"\n Sc_rollup_commitment_repr.Hash.encoding)\n (req \"output_proof\" (string Hex));\n select =\n (function\n | Manager (Sc_rollup_execute_outbox_message _ as op) -> Some op\n | _ -> None);\n proj =\n (function\n | Sc_rollup_execute_outbox_message\n {rollup; cemented_commitment; output_proof} ->\n (rollup, cemented_commitment, output_proof));\n inj =\n (fun (rollup, cemented_commitment, output_proof) ->\n Sc_rollup_execute_outbox_message\n {rollup; cemented_commitment; output_proof});\n }\n\n let sc_rollup_recover_bond_case =\n MCase\n {\n tag = sc_rollup_operation_recover_bond_tag;\n name = \"smart_rollup_recover_bond\";\n encoding =\n obj2\n (req \"rollup\" Sc_rollup_repr.Address.encoding)\n (req \"staker\" Signature.Public_key_hash.encoding);\n select =\n (function\n | Manager (Sc_rollup_recover_bond _ as op) -> Some op | _ -> None);\n proj =\n (function\n | Sc_rollup_recover_bond {sc_rollup; staker} -> (sc_rollup, staker));\n inj =\n (fun (sc_rollup, staker) ->\n Sc_rollup_recover_bond {sc_rollup; staker});\n }\n end\n\n type 'b case =\n | Case : {\n tag : int;\n name : string;\n encoding : 'a Data_encoding.t;\n select : packed_contents -> 'b contents option;\n proj : 'b contents -> 'a;\n inj : 'a -> 'b contents;\n }\n -> 'b case\n\n let preendorsement_case =\n Case\n {\n tag = 20;\n name = \"preendorsement\";\n encoding = consensus_content_encoding;\n select =\n (function Contents (Preendorsement _ as op) -> Some op | _ -> None);\n proj = (fun (Preendorsement preendorsement) -> preendorsement);\n inj = (fun preendorsement -> Preendorsement preendorsement);\n }\n\n let preendorsement_encoding =\n let make (Case {tag; name; encoding; select = _; proj; inj}) =\n case (Tag tag) name encoding (fun o -> Some (proj o)) (fun x -> inj x)\n in\n let to_list : Kind.preendorsement contents_list -> _ = function\n | Single o -> o\n in\n let of_list : Kind.preendorsement contents -> _ = function\n | o -> Single o\n in\n def \"inlined.preendorsement\"\n @@ conv\n (fun ({shell; protocol_data = {contents; signature}} : _ operation) ->\n (shell, (contents, signature)))\n (fun (shell, (contents, signature)) : _ operation ->\n {shell; protocol_data = {contents; signature}})\n (merge_objs\n Operation.shell_header_encoding\n (obj2\n (req\n \"operations\"\n (conv to_list of_list\n @@ def \"inlined.preendorsement.contents\"\n @@ union [make preendorsement_case]))\n (varopt \"signature\" Signature.encoding)))\n\n let endorsement_encoding =\n obj4\n (req \"slot\" Slot_repr.encoding)\n (req \"level\" Raw_level_repr.encoding)\n (req \"round\" Round_repr.encoding)\n (req \"block_payload_hash\" Block_payload_hash.encoding)\n\n let endorsement_case =\n Case\n {\n tag = 21;\n name = \"endorsement\";\n encoding = endorsement_encoding;\n select =\n (function Contents (Endorsement _ as op) -> Some op | _ -> None);\n proj =\n (fun (Endorsement consensus_content) ->\n ( consensus_content.slot,\n consensus_content.level,\n consensus_content.round,\n consensus_content.block_payload_hash ));\n inj =\n (fun (slot, level, round, block_payload_hash) ->\n Endorsement {slot; level; round; block_payload_hash});\n }\n\n let endorsement_encoding =\n let make (Case {tag; name; encoding; select = _; proj; inj}) =\n case (Tag tag) name encoding (fun o -> Some (proj o)) (fun x -> inj x)\n in\n let to_list : Kind.endorsement contents_list -> _ = fun (Single o) -> o in\n let of_list : Kind.endorsement contents -> _ = fun o -> Single o in\n def \"inlined.endorsement\"\n @@ conv\n (fun ({shell; protocol_data = {contents; signature}} : _ operation) ->\n (shell, (contents, signature)))\n (fun (shell, (contents, signature)) : _ operation ->\n {shell; protocol_data = {contents; signature}})\n (merge_objs\n Operation.shell_header_encoding\n (obj2\n (req\n \"operations\"\n (conv to_list of_list\n @@ def \"inlined.endorsement_mempool.contents\"\n @@ union [make endorsement_case]))\n (varopt \"signature\" Signature.encoding)))\n\n let dal_attestation_encoding =\n obj3\n (req \"attestor\" Signature.Public_key_hash.encoding)\n (req \"attestation\" Dal_attestation_repr.encoding)\n (req \"level\" Raw_level_repr.encoding)\n\n let dal_attestation_case =\n Case\n {\n tag = 22;\n name = \"dal_attestation\";\n encoding = dal_attestation_encoding;\n select =\n (function Contents (Dal_attestation _ as op) -> Some op | _ -> None);\n proj =\n (fun (Dal_attestation\n Dal_attestation_repr.{attestor; attestation; level}) ->\n (attestor, attestation, level));\n inj =\n (fun (attestor, attestation, level) ->\n Dal_attestation Dal_attestation_repr.{attestor; attestation; level});\n }\n\n let seed_nonce_revelation_case =\n Case\n {\n tag = 1;\n name = \"seed_nonce_revelation\";\n encoding =\n obj2\n (req \"level\" Raw_level_repr.encoding)\n (req \"nonce\" Seed_repr.nonce_encoding);\n select =\n (function\n | Contents (Seed_nonce_revelation _ as op) -> Some op | _ -> None);\n proj = (fun (Seed_nonce_revelation {level; nonce}) -> (level, nonce));\n inj = (fun (level, nonce) -> Seed_nonce_revelation {level; nonce});\n }\n\n let vdf_revelation_case =\n Case\n {\n tag = 8;\n name = \"vdf_revelation\";\n encoding = obj1 (req \"solution\" Seed_repr.vdf_solution_encoding);\n select =\n (function Contents (Vdf_revelation _ as op) -> Some op | _ -> None);\n proj = (function Vdf_revelation {solution} -> solution);\n inj = (fun solution -> Vdf_revelation {solution});\n }\n\n let double_preendorsement_evidence_case :\n Kind.double_preendorsement_evidence case =\n Case\n {\n tag = 7;\n name = \"double_preendorsement_evidence\";\n encoding =\n obj2\n (req \"op1\" (dynamic_size preendorsement_encoding))\n (req \"op2\" (dynamic_size preendorsement_encoding));\n select =\n (function\n | Contents (Double_preendorsement_evidence _ as op) -> Some op\n | _ -> None);\n proj = (fun (Double_preendorsement_evidence {op1; op2}) -> (op1, op2));\n inj = (fun (op1, op2) -> Double_preendorsement_evidence {op1; op2});\n }\n\n let double_endorsement_evidence_case : Kind.double_endorsement_evidence case =\n Case\n {\n tag = 2;\n name = \"double_endorsement_evidence\";\n encoding =\n obj2\n (req \"op1\" (dynamic_size endorsement_encoding))\n (req \"op2\" (dynamic_size endorsement_encoding));\n select =\n (function\n | Contents (Double_endorsement_evidence _ as op) -> Some op\n | _ -> None);\n proj = (fun (Double_endorsement_evidence {op1; op2}) -> (op1, op2));\n inj = (fun (op1, op2) -> Double_endorsement_evidence {op1; op2});\n }\n\n let double_baking_evidence_case =\n Case\n {\n tag = 3;\n name = \"double_baking_evidence\";\n encoding =\n obj2\n (req \"bh1\" (dynamic_size Block_header_repr.encoding))\n (req \"bh2\" (dynamic_size Block_header_repr.encoding));\n select =\n (function\n | Contents (Double_baking_evidence _ as op) -> Some op | _ -> None);\n proj = (fun (Double_baking_evidence {bh1; bh2}) -> (bh1, bh2));\n inj = (fun (bh1, bh2) -> Double_baking_evidence {bh1; bh2});\n }\n\n let activate_account_case =\n Case\n {\n tag = 4;\n name = \"activate_account\";\n encoding =\n obj2\n (req \"pkh\" Ed25519.Public_key_hash.encoding)\n (req \"secret\" Blinded_public_key_hash.activation_code_encoding);\n select =\n (function\n | Contents (Activate_account _ as op) -> Some op | _ -> None);\n proj =\n (fun (Activate_account {id; activation_code}) ->\n (id, activation_code));\n inj =\n (fun (id, activation_code) -> Activate_account {id; activation_code});\n }\n\n let proposals_case =\n Case\n {\n tag = 5;\n name = \"proposals\";\n encoding =\n obj3\n (req \"source\" Signature.Public_key_hash.encoding)\n (req \"period\" int32)\n (req\n \"proposals\"\n (list\n ~max_length:Constants_repr.max_proposals_per_delegate\n Protocol_hash.encoding));\n select =\n (function Contents (Proposals _ as op) -> Some op | _ -> None);\n proj =\n (fun (Proposals {source; period; proposals}) ->\n (source, period, proposals));\n inj =\n (fun (source, period, proposals) ->\n Proposals {source; period; proposals});\n }\n\n let ballot_case =\n Case\n {\n tag = 6;\n name = \"ballot\";\n encoding =\n obj4\n (req \"source\" Signature.Public_key_hash.encoding)\n (req \"period\" int32)\n (req \"proposal\" Protocol_hash.encoding)\n (req \"ballot\" Vote_repr.ballot_encoding);\n select = (function Contents (Ballot _ as op) -> Some op | _ -> None);\n proj =\n (function\n | Ballot {source; period; proposal; ballot} ->\n (source, period, proposal, ballot));\n inj =\n (fun (source, period, proposal, ballot) ->\n Ballot {source; period; proposal; ballot});\n }\n\n let drain_delegate_case =\n Case\n {\n tag = 9;\n name = \"drain_delegate\";\n encoding =\n obj3\n (req \"consensus_key\" Signature.Public_key_hash.encoding)\n (req \"delegate\" Signature.Public_key_hash.encoding)\n (req \"destination\" Signature.Public_key_hash.encoding);\n select =\n (function Contents (Drain_delegate _ as op) -> Some op | _ -> None);\n proj =\n (function\n | Drain_delegate {consensus_key; delegate; destination} ->\n (consensus_key, delegate, destination));\n inj =\n (fun (consensus_key, delegate, destination) ->\n Drain_delegate {consensus_key; delegate; destination});\n }\n\n let failing_noop_case =\n Case\n {\n tag = 17;\n name = \"failing_noop\";\n encoding = obj1 (req \"arbitrary\" (string Hex));\n select =\n (function Contents (Failing_noop _ as op) -> Some op | _ -> None);\n proj = (function Failing_noop message -> message);\n inj = (function message -> Failing_noop message);\n }\n\n let manager_encoding =\n obj5\n (req \"source\" Signature.Public_key_hash.encoding)\n (req \"fee\" Tez_repr.encoding)\n (req \"counter\" Manager_counter_repr.encoding_for_operation)\n (req \"gas_limit\" (check_size 10 Gas_limit_repr.Arith.n_integral_encoding))\n (req \"storage_limit\" (check_size 10 n))\n\n let extract : type kind. kind Kind.manager contents -> _ = function\n | Manager_operation\n {source; fee; counter; gas_limit; storage_limit; operation = _} ->\n (source, fee, counter, gas_limit, storage_limit)\n\n let rebuild (source, fee, counter, gas_limit, storage_limit) operation =\n Manager_operation\n {source; fee; counter; gas_limit; storage_limit; operation}\n\n let make_manager_case tag (type kind)\n (Manager_operations.MCase mcase : kind Manager_operations.case) =\n Case\n {\n tag;\n name = mcase.name;\n encoding = merge_objs manager_encoding mcase.encoding;\n select =\n (function\n | Contents (Manager_operation ({operation; _} as op)) -> (\n match mcase.select (Manager operation) with\n | None -> None\n | Some operation -> Some (Manager_operation {op with operation}))\n | _ -> None);\n proj =\n (function\n | Manager_operation {operation; _} as op ->\n (extract op, mcase.proj operation));\n inj = (fun (op, contents) -> rebuild op (mcase.inj contents));\n }\n\n let reveal_case = make_manager_case 107 Manager_operations.reveal_case\n\n let transaction_case =\n make_manager_case 108 Manager_operations.transaction_case\n\n let origination_case =\n make_manager_case 109 Manager_operations.origination_case\n\n let delegation_case = make_manager_case 110 Manager_operations.delegation_case\n\n let register_global_constant_case =\n make_manager_case 111 Manager_operations.register_global_constant_case\n\n let set_deposits_limit_case =\n make_manager_case 112 Manager_operations.set_deposits_limit_case\n\n let increase_paid_storage_case =\n make_manager_case 113 Manager_operations.increase_paid_storage_case\n\n let update_consensus_key_case =\n make_manager_case 114 Manager_operations.update_consensus_key_case\n\n let tx_rollup_origination_case =\n make_manager_case\n tx_rollup_operation_tag_offset\n Manager_operations.tx_rollup_origination_case\n\n let tx_rollup_submit_batch_case =\n make_manager_case\n tx_rollup_operation_submit_batch_tag\n Manager_operations.tx_rollup_submit_batch_case\n\n let tx_rollup_commit_case =\n make_manager_case\n tx_rollup_operation_commit_tag\n Manager_operations.tx_rollup_commit_case\n\n let tx_rollup_return_bond_case =\n make_manager_case\n tx_rollup_operation_return_bond_tag\n Manager_operations.tx_rollup_return_bond_case\n\n let tx_rollup_finalize_commitment_case =\n make_manager_case\n tx_rollup_operation_finalize_commitment_tag\n Manager_operations.tx_rollup_finalize_commitment_case\n\n let tx_rollup_remove_commitment_case =\n make_manager_case\n tx_rollup_operation_remove_commitment_tag\n Manager_operations.tx_rollup_remove_commitment_case\n\n let tx_rollup_rejection_case =\n make_manager_case\n tx_rollup_operation_rejection_tag\n Manager_operations.tx_rollup_rejection_case\n\n let tx_rollup_dispatch_tickets_case =\n make_manager_case\n tx_rollup_operation_dispatch_tickets_tag\n Manager_operations.tx_rollup_dispatch_tickets_case\n\n let transfer_ticket_case =\n make_manager_case\n transfer_ticket_tag\n Manager_operations.transfer_ticket_case\n\n let dal_publish_slot_header_case =\n make_manager_case\n dal_publish_slot_header_tag\n Manager_operations.dal_publish_slot_header_case\n\n let sc_rollup_originate_case =\n make_manager_case\n sc_rollup_operation_origination_tag\n Manager_operations.sc_rollup_originate_case\n\n let sc_rollup_add_messages_case =\n make_manager_case\n sc_rollup_operation_add_message_tag\n Manager_operations.sc_rollup_add_messages_case\n\n let sc_rollup_cement_case =\n make_manager_case\n sc_rollup_operation_cement_tag\n Manager_operations.sc_rollup_cement_case\n\n let sc_rollup_publish_case =\n make_manager_case\n sc_rollup_operation_publish_tag\n Manager_operations.sc_rollup_publish_case\n\n let sc_rollup_refute_case =\n make_manager_case\n sc_rollup_operation_refute_tag\n Manager_operations.sc_rollup_refute_case\n\n let sc_rollup_timeout_case =\n make_manager_case\n sc_rollup_operation_timeout_tag\n Manager_operations.sc_rollup_timeout_case\n\n let sc_rollup_execute_outbox_message_case =\n make_manager_case\n sc_rollup_execute_outbox_message_tag\n Manager_operations.sc_rollup_execute_outbox_message_case\n\n let sc_rollup_recover_bond_case =\n make_manager_case\n sc_rollup_operation_recover_bond_tag\n Manager_operations.sc_rollup_recover_bond_case\n\n let zk_rollup_origination_case =\n make_manager_case\n zk_rollup_operation_create_tag\n Manager_operations.zk_rollup_origination_case\n\n let zk_rollup_publish_case =\n make_manager_case\n zk_rollup_operation_publish_tag\n Manager_operations.zk_rollup_publish_case\n\n let zk_rollup_update_case =\n make_manager_case\n zk_rollup_operation_update_tag\n Manager_operations.zk_rollup_update_case\n\n type packed_case = PCase : 'b case -> packed_case\n\n let contents_cases =\n [\n PCase endorsement_case;\n PCase preendorsement_case;\n PCase dal_attestation_case;\n PCase seed_nonce_revelation_case;\n PCase vdf_revelation_case;\n PCase double_endorsement_evidence_case;\n PCase double_preendorsement_evidence_case;\n PCase double_baking_evidence_case;\n PCase activate_account_case;\n PCase proposals_case;\n PCase ballot_case;\n PCase reveal_case;\n PCase transaction_case;\n PCase origination_case;\n PCase delegation_case;\n PCase set_deposits_limit_case;\n PCase increase_paid_storage_case;\n PCase update_consensus_key_case;\n PCase drain_delegate_case;\n PCase failing_noop_case;\n PCase register_global_constant_case;\n PCase tx_rollup_origination_case;\n PCase tx_rollup_submit_batch_case;\n PCase tx_rollup_commit_case;\n PCase tx_rollup_return_bond_case;\n PCase tx_rollup_finalize_commitment_case;\n PCase tx_rollup_remove_commitment_case;\n PCase tx_rollup_rejection_case;\n PCase tx_rollup_dispatch_tickets_case;\n PCase transfer_ticket_case;\n PCase dal_publish_slot_header_case;\n PCase sc_rollup_originate_case;\n PCase sc_rollup_add_messages_case;\n PCase sc_rollup_cement_case;\n PCase sc_rollup_publish_case;\n PCase sc_rollup_refute_case;\n PCase sc_rollup_timeout_case;\n PCase sc_rollup_execute_outbox_message_case;\n PCase sc_rollup_recover_bond_case;\n PCase zk_rollup_origination_case;\n PCase zk_rollup_publish_case;\n PCase zk_rollup_update_case;\n ]\n\n let contents_encoding =\n let make (PCase (Case {tag; name; encoding; select; proj; inj})) =\n assert (not @@ reserved_tag tag) ;\n case\n (Tag tag)\n name\n encoding\n (fun o -> match select o with None -> None | Some o -> Some (proj o))\n (fun x -> Contents (inj x))\n in\n def \"operation.alpha.contents\" @@ union (List.map make contents_cases)\n\n let contents_list_encoding =\n conv_with_guard to_list of_list_internal (Variable.list contents_encoding)\n\n let protocol_data_json_encoding =\n conv\n (fun (Operation_data {contents; signature}) ->\n (Contents_list contents, signature))\n (fun (Contents_list contents, signature) ->\n Operation_data {contents; signature})\n (obj2\n (req \"contents\" (dynamic_size contents_list_encoding))\n (opt \"signature\" Signature.encoding))\n\n type contents_or_signature_prefix =\n | Actual_contents of packed_contents\n | Signature_prefix of Signature.prefix\n\n let contents_or_signature_prefix_encoding =\n let make_contents (PCase (Case {tag; name; encoding; select; proj; inj})) =\n assert (not @@ reserved_tag tag) ;\n case\n (Tag tag)\n name\n encoding\n (function\n | Actual_contents o -> (\n match select o with None -> None | Some o -> Some (proj o))\n | _ -> None)\n (fun x -> Actual_contents (Contents (inj x)))\n in\n def \"operation.alpha.contents_or_signature_prefix\"\n @@ union\n @@ case\n (Tag signature_prefix_tag)\n \"signature_prefix\"\n (obj1 (req \"signature_prefix\" Signature.prefix_encoding))\n (function Signature_prefix prefix -> Some prefix | _ -> None)\n (fun prefix -> Signature_prefix prefix)\n (* The case signature_prefix is added to the operation's contents so that\n we can store the prefix of BLS signatures without breaking the\n encoding of operations. *)\n :: List.map make_contents contents_cases\n\n let of_contents_and_signature_prefix contents_and_prefix =\n let open Result_syntax in\n let rec loop acc = function\n | [] -> Ok acc\n | Signature_prefix _ :: _ -> Error \"Signature prefix must appear last\"\n | Actual_contents (Contents o) :: os -> (\n match (o, acc) with\n | ( Manager_operation _,\n Contents_list (Single (Manager_operation _) as rest) ) ->\n (loop [@tailcall]) (Contents_list (Cons (o, rest))) os\n | Manager_operation _, Contents_list (Cons _ as rest) ->\n (loop [@tailcall]) (Contents_list (Cons (o, rest))) os\n | _ ->\n Error\n \"Operation list of length > 1 should only contain manager \\\n operations.\")\n in\n let rev_contents, prefix =\n match List.rev contents_and_prefix with\n | Signature_prefix prefix :: rev_contents -> (rev_contents, Some prefix)\n | rev_contents -> (rev_contents, None)\n in\n let+ packed_contents =\n match rev_contents with\n | [] -> Error \"Operation lists should not be empty.\"\n | Signature_prefix _ :: _ -> Error \"Signature prefix must appear last\"\n | Actual_contents (Contents o) :: os -> loop (Contents_list (Single o)) os\n in\n (packed_contents, prefix)\n\n let protocol_data_binary_encoding =\n conv_with_guard\n (fun (Operation_data {contents; signature}) ->\n let contents_list =\n List.map (fun c -> Actual_contents c)\n @@ to_list (Contents_list contents)\n in\n let contents_and_signature_prefix, sig_suffix =\n match signature with\n | None -> (contents_list, Signature.(to_bytes zero))\n | Some signature -> (\n let {Signature.prefix; suffix} =\n Signature.split_signature signature\n in\n match prefix with\n | None -> (contents_list, suffix)\n | Some prefix ->\n (contents_list @ [Signature_prefix prefix], suffix))\n in\n (contents_and_signature_prefix, sig_suffix))\n (fun (contents_and_signature_prefix, suffix) ->\n let open Result_syntax in\n let* Contents_list contents, prefix =\n of_contents_and_signature_prefix contents_and_signature_prefix\n in\n let+ signature =\n Result.of_option ~error:\"Invalid signature\"\n @@ Signature.of_splitted {Signature.prefix; suffix}\n in\n let signature =\n match prefix with\n | None ->\n if Signature.(signature = zero) then None else Some signature\n | Some _ -> Some signature\n in\n Operation_data {contents; signature})\n (obj2\n (req\n \"contents_and_signature_prefix\"\n (Variable.list contents_or_signature_prefix_encoding))\n (req \"signature_suffix\" (Fixed.bytes Hex 64)))\n\n (* The binary and JSON encodings are different for protocol data, because we\n have to fit BLS signatures (which are 96 bytes long) in a backward\n compatible manner with fixed size signatures of 64 bytes.\n\n The JSON encoding is the same as in the previous protocols.\n\n To support BLS signatures, we extract the prefix of the signature and fit\n it inside the field [contents] while keeping the 64 bytes suffix in the\n same place as the other signature kinds (i.e. at the end).\n\n For instance the binary protocol data for a transfer operation signed by a\n Ed25519 key would look like:\n\n +----------------+------------+\n | Transaction | signature |\n +----+------+----+------------+\n | 6C | ... | 00 | (64 bytes) |\n +----+------+----+------------+\n\n The same transfer signed by a BLS key would be instead:\n\n +----------------+----------------------------+-------------------+\n | Transaction | signature prefix | signature suffix |\n +----+------+----+----+----+------------------+-------------------+\n | 6C | ... | 00 | ff | 03 | (first 32 bytes) | (last 64 bytes) |\n +----+------+----+----+----+------------------+-------------------+\n\n Which can also be viewed with an equivalent schema:\n\n +----------------+----+---------------+--------------------------+\n | Transaction | ff | signature tag | signature |\n +----+------+----+----+---------------+--------------------------+\n | 6C | ... | 00 | ff | 03 (BLS) | (96 bytes BLS signature) |\n +----+------+----+----+---------------+--------------------------+\n\n NOTE: BLS only supports the tagged format and Ed25519, Secp256k1 and P256\n signatures only support the untagged one. The latter restriction is only\n here to guarantee unicity of the binary representation for signatures.\n *)\n let protocol_data_encoding =\n def \"operation.alpha.contents_and_signature\"\n @@ splitted\n ~json:protocol_data_json_encoding\n ~binary:protocol_data_binary_encoding\n\n let operation_encoding =\n conv\n (fun {shell; protocol_data} -> (shell, protocol_data))\n (fun (shell, protocol_data) -> {shell; protocol_data})\n (merge_objs Operation.shell_header_encoding protocol_data_encoding)\n\n let unsigned_operation_encoding =\n def \"operation.alpha.unsigned_operation\"\n @@ merge_objs\n Operation.shell_header_encoding\n (obj1 (req \"contents\" contents_list_encoding))\nend\n\nlet encoding = Encoding.operation_encoding\n\nlet contents_encoding = Encoding.contents_encoding\n\nlet contents_list_encoding = Encoding.contents_list_encoding\n\nlet protocol_data_encoding = Encoding.protocol_data_encoding\n\nlet unsigned_operation_encoding = Encoding.unsigned_operation_encoding\n\nlet raw ({shell; protocol_data} : _ operation) =\n let proto =\n Data_encoding.Binary.to_bytes_exn\n protocol_data_encoding\n (Operation_data protocol_data)\n in\n {Operation.shell; proto}\n\n(** Each operation belongs to a validation pass that is an integer\n abstracting its priority in a block. Except Failing_noop. *)\n\nlet consensus_pass = 0\n\nlet voting_pass = 1\n\nlet anonymous_pass = 2\n\nlet manager_pass = 3\n\n(** [acceptable_pass op] returns either the validation_pass of [op]\n when defines and None when [op] is [Failing_noop]. *)\nlet acceptable_pass (op : packed_operation) =\n let (Operation_data protocol_data) = op.protocol_data in\n match protocol_data.contents with\n | Single (Failing_noop _) -> None\n | Single (Preendorsement _) -> Some consensus_pass\n | Single (Endorsement _) -> Some consensus_pass\n | Single (Dal_attestation _) -> Some consensus_pass\n | Single (Proposals _) -> Some voting_pass\n | Single (Ballot _) -> Some voting_pass\n | Single (Seed_nonce_revelation _) -> Some anonymous_pass\n | Single (Vdf_revelation _) -> Some anonymous_pass\n | Single (Double_endorsement_evidence _) -> Some anonymous_pass\n | Single (Double_preendorsement_evidence _) -> Some anonymous_pass\n | Single (Double_baking_evidence _) -> Some anonymous_pass\n | Single (Activate_account _) -> Some anonymous_pass\n | Single (Drain_delegate _) -> Some anonymous_pass\n | Single (Manager_operation _) -> Some manager_pass\n | Cons (Manager_operation _, _ops) -> Some manager_pass\n\n(** [compare_by_passes] orders two operations in the reverse order of\n their acceptable passes. *)\nlet compare_by_passes op1 op2 =\n match (acceptable_pass op1, acceptable_pass op2) with\n | Some op1_pass, Some op2_pass -> Compare.Int.compare op2_pass op1_pass\n | None, Some _ -> -1\n | Some _, None -> 1\n | None, None -> 0\n\ntype error += Invalid_signature (* `Permanent *)\n\ntype error += Missing_signature (* `Permanent *)\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"operation.invalid_signature\"\n ~title:\"Invalid operation signature\"\n ~description:\n \"The operation signature is ill-formed or has been made with the wrong \\\n public key\"\n ~pp:(fun ppf () -> Format.fprintf ppf \"The operation signature is invalid\")\n Data_encoding.unit\n (function Invalid_signature -> Some () | _ -> None)\n (fun () -> Invalid_signature) ;\n register_error_kind\n `Permanent\n ~id:\"operation.missing_signature\"\n ~title:\"Missing operation signature\"\n ~description:\n \"The operation is of a kind that must be signed, but the signature is \\\n missing\"\n ~pp:(fun ppf () -> Format.fprintf ppf \"The operation requires a signature\")\n Data_encoding.unit\n (function Missing_signature -> Some () | _ -> None)\n (fun () -> Missing_signature) ;\n register_error_kind\n `Permanent\n ~id:\"operation.contents_list_error\"\n ~title:\"Invalid list of operation contents.\"\n ~description:\n \"An operation contents list has an unexpected shape; it should be either \\\n a single operation or a non-empty list of manager operations\"\n ~pp:(fun ppf s ->\n Format.fprintf\n ppf\n \"An operation contents list has an unexpected shape: %s\"\n s)\n Data_encoding.(obj1 (req \"message\" (string Hex)))\n (function Contents_list_error s -> Some s | _ -> None)\n (fun s -> Contents_list_error s)\n\nlet check_signature (type kind) key chain_id\n ({shell; protocol_data} : kind operation) =\n let check ~watermark contents signature =\n let unsigned_operation =\n Data_encoding.Binary.to_bytes_exn\n unsigned_operation_encoding\n (shell, contents)\n in\n if Signature.check ~watermark key signature unsigned_operation then Ok ()\n else error Invalid_signature\n in\n match protocol_data.signature with\n | None -> error Missing_signature\n | Some signature -> (\n match protocol_data.contents with\n | Single (Preendorsement _) as contents ->\n check\n ~watermark:(to_watermark (Preendorsement chain_id))\n (Contents_list contents)\n signature\n | Single (Endorsement _) as contents ->\n check\n ~watermark:(to_watermark (Endorsement chain_id))\n (Contents_list contents)\n signature\n | Single (Dal_attestation _) as contents ->\n check\n ~watermark:(to_watermark (Dal_attestation chain_id))\n (Contents_list contents)\n signature\n | Single\n ( Failing_noop _ | Proposals _ | Ballot _ | Seed_nonce_revelation _\n | Vdf_revelation _ | Double_endorsement_evidence _\n | Double_preendorsement_evidence _ | Double_baking_evidence _\n | Activate_account _ | Drain_delegate _ | Manager_operation _ ) ->\n check\n ~watermark:Generic_operation\n (Contents_list protocol_data.contents)\n signature\n | Cons (Manager_operation _, _ops) ->\n check\n ~watermark:Generic_operation\n (Contents_list protocol_data.contents)\n signature)\n\nlet hash_raw = Operation.hash\n\nlet hash (o : _ operation) =\n let proto =\n Data_encoding.Binary.to_bytes_exn\n protocol_data_encoding\n (Operation_data o.protocol_data)\n in\n Operation.hash {shell = o.shell; proto}\n\nlet hash_packed (o : packed_operation) =\n let proto =\n Data_encoding.Binary.to_bytes_exn protocol_data_encoding o.protocol_data\n in\n Operation.hash {shell = o.shell; proto}\n\ntype ('a, 'b) eq = Eq : ('a, 'a) eq\n\nlet equal_manager_operation_kind :\n type a b. a manager_operation -> b manager_operation -> (a, b) eq option =\n fun op1 op2 ->\n match (op1, op2) with\n | Reveal _, Reveal _ -> Some Eq\n | Reveal _, _ -> None\n | Transaction _, Transaction _ -> Some Eq\n | Transaction _, _ -> None\n | Origination _, Origination _ -> Some Eq\n | Origination _, _ -> None\n | Delegation _, Delegation _ -> Some Eq\n | Delegation _, _ -> None\n | Register_global_constant _, Register_global_constant _ -> Some Eq\n | Register_global_constant _, _ -> None\n | Set_deposits_limit _, Set_deposits_limit _ -> Some Eq\n | Set_deposits_limit _, _ -> None\n | Increase_paid_storage _, Increase_paid_storage _ -> Some Eq\n | Increase_paid_storage _, _ -> None\n | Update_consensus_key _, Update_consensus_key _ -> Some Eq\n | Update_consensus_key _, _ -> None\n | Tx_rollup_origination, Tx_rollup_origination -> Some Eq\n | Tx_rollup_origination, _ -> None\n | Tx_rollup_submit_batch _, Tx_rollup_submit_batch _ -> Some Eq\n | Tx_rollup_submit_batch _, _ -> None\n | Tx_rollup_commit _, Tx_rollup_commit _ -> Some Eq\n | Tx_rollup_commit _, _ -> None\n | Tx_rollup_return_bond _, Tx_rollup_return_bond _ -> Some Eq\n | Tx_rollup_return_bond _, _ -> None\n | Tx_rollup_finalize_commitment _, Tx_rollup_finalize_commitment _ -> Some Eq\n | Tx_rollup_finalize_commitment _, _ -> None\n | Tx_rollup_remove_commitment _, Tx_rollup_remove_commitment _ -> Some Eq\n | Tx_rollup_remove_commitment _, _ -> None\n | Tx_rollup_rejection _, Tx_rollup_rejection _ -> Some Eq\n | Tx_rollup_rejection _, _ -> None\n | Tx_rollup_dispatch_tickets _, Tx_rollup_dispatch_tickets _ -> Some Eq\n | Tx_rollup_dispatch_tickets _, _ -> None\n | Transfer_ticket _, Transfer_ticket _ -> Some Eq\n | Transfer_ticket _, _ -> None\n | Dal_publish_slot_header _, Dal_publish_slot_header _ -> Some Eq\n | Dal_publish_slot_header _, _ -> None\n | Sc_rollup_originate _, Sc_rollup_originate _ -> Some Eq\n | Sc_rollup_originate _, _ -> None\n | Sc_rollup_add_messages _, Sc_rollup_add_messages _ -> Some Eq\n | Sc_rollup_add_messages _, _ -> None\n | Sc_rollup_cement _, Sc_rollup_cement _ -> Some Eq\n | Sc_rollup_cement _, _ -> None\n | Sc_rollup_publish _, Sc_rollup_publish _ -> Some Eq\n | Sc_rollup_publish _, _ -> None\n | Sc_rollup_refute _, Sc_rollup_refute _ -> Some Eq\n | Sc_rollup_refute _, _ -> None\n | Sc_rollup_timeout _, Sc_rollup_timeout _ -> Some Eq\n | Sc_rollup_timeout _, _ -> None\n | Sc_rollup_execute_outbox_message _, Sc_rollup_execute_outbox_message _ ->\n Some Eq\n | Sc_rollup_execute_outbox_message _, _ -> None\n | Sc_rollup_recover_bond _, Sc_rollup_recover_bond _ -> Some Eq\n | Sc_rollup_recover_bond _, _ -> None\n | Zk_rollup_origination _, Zk_rollup_origination _ -> Some Eq\n | Zk_rollup_origination _, _ -> None\n | Zk_rollup_publish _, Zk_rollup_publish _ -> Some Eq\n | Zk_rollup_publish _, _ -> None\n | Zk_rollup_update _, Zk_rollup_update _ -> Some Eq\n | Zk_rollup_update _, _ -> None\n\nlet equal_contents_kind : type a b. a contents -> b contents -> (a, b) eq option\n =\n fun op1 op2 ->\n match (op1, op2) with\n | Preendorsement _, Preendorsement _ -> Some Eq\n | Preendorsement _, _ -> None\n | Endorsement _, Endorsement _ -> Some Eq\n | Endorsement _, _ -> None\n | Dal_attestation _, Dal_attestation _ -> Some Eq\n | Dal_attestation _, _ -> None\n | Seed_nonce_revelation _, Seed_nonce_revelation _ -> Some Eq\n | Seed_nonce_revelation _, _ -> None\n | Vdf_revelation _, Vdf_revelation _ -> Some Eq\n | Vdf_revelation _, _ -> None\n | Double_endorsement_evidence _, Double_endorsement_evidence _ -> Some Eq\n | Double_endorsement_evidence _, _ -> None\n | Double_preendorsement_evidence _, Double_preendorsement_evidence _ ->\n Some Eq\n | Double_preendorsement_evidence _, _ -> None\n | Double_baking_evidence _, Double_baking_evidence _ -> Some Eq\n | Double_baking_evidence _, _ -> None\n | Activate_account _, Activate_account _ -> Some Eq\n | Activate_account _, _ -> None\n | Proposals _, Proposals _ -> Some Eq\n | Proposals _, _ -> None\n | Ballot _, Ballot _ -> Some Eq\n | Ballot _, _ -> None\n | Drain_delegate _, Drain_delegate _ -> Some Eq\n | Drain_delegate _, _ -> None\n | Failing_noop _, Failing_noop _ -> Some Eq\n | Failing_noop _, _ -> None\n | Manager_operation op1, Manager_operation op2 -> (\n match equal_manager_operation_kind op1.operation op2.operation with\n | None -> None\n | Some Eq -> Some Eq)\n | Manager_operation _, _ -> None\n\nlet rec equal_contents_kind_list :\n type a b. a contents_list -> b contents_list -> (a, b) eq option =\n fun op1 op2 ->\n match (op1, op2) with\n | Single op1, Single op2 -> equal_contents_kind op1 op2\n | Single _, Cons _ -> None\n | Cons _, Single _ -> None\n | Cons (op1, ops1), Cons (op2, ops2) -> (\n match equal_contents_kind op1 op2 with\n | None -> None\n | Some Eq -> (\n match equal_contents_kind_list ops1 ops2 with\n | None -> None\n | Some Eq -> Some Eq))\n\nlet equal : type a b. a operation -> b operation -> (a, b) eq option =\n fun op1 op2 ->\n if not (Operation_hash.equal (hash op1) (hash op2)) then None\n else\n equal_contents_kind_list\n op1.protocol_data.contents\n op2.protocol_data.contents\n\n(** {2 Comparing operations} *)\n\n(** Precondition: both operations are [valid]. Hence, it is possible\n to compare them without any state representation. *)\n\n(** {3 Operation passes} *)\n\ntype consensus_pass_type\n\ntype voting_pass_type\n\ntype anonymous_pass_type\n\ntype manager_pass_type\n\ntype noop_pass_type\n\ntype _ pass =\n | Consensus : consensus_pass_type pass\n | Voting : voting_pass_type pass\n | Anonymous : anonymous_pass_type pass\n | Manager : manager_pass_type pass\n | Noop : noop_pass_type pass\n\n(** Pass comparison. *)\nlet compare_inner_pass : type a b. a pass -> b pass -> int =\n fun pass1 pass2 ->\n match (pass1, pass2) with\n | Consensus, (Voting | Anonymous | Manager | Noop) -> 1\n | (Voting | Anonymous | Manager | Noop), Consensus -> -1\n | Voting, (Anonymous | Manager | Noop) -> 1\n | (Anonymous | Manager | Noop), Voting -> -1\n | Anonymous, (Manager | Noop) -> 1\n | (Manager | Noop), Anonymous -> -1\n | Manager, Noop -> 1\n | Noop, Manager -> -1\n | Consensus, Consensus\n | Voting, Voting\n | Anonymous, Anonymous\n | Manager, Manager\n | Noop, Noop ->\n 0\n\n(** {3 Operation weights} *)\n\n(** [round_infos] is the pair of a [level] convert into {!int32} and\n [round] convert into an {!int}.\n\n By convention, if the [round] is from an operation round that\n failed to convert in a {!int}, the value of [round] is (-1). *)\ntype round_infos = {level : int32; round : int}\n\n(** [endorsement_infos] is the pair of a {!round_infos} and a [slot]\n convert into an {!int}. *)\ntype endorsement_infos = {round : round_infos; slot : int}\n\n(** [double_baking_infos] is the pair of a {!round_infos} and a\n {!block_header} hash. *)\ntype double_baking_infos = {round : round_infos; bh_hash : Block_hash.t}\n\n(** Compute a {!round_infos} from a {consensus_content} of a valid\n operation. Hence, the [round] must convert in {!int}.\n\n Precondition: [c] comes from a valid operation. The [round] from a\n valid operation should succeed to convert in {!int}. Hence, for the\n unreachable path where the convertion failed, we put (-1) as\n [round] value. *)\nlet round_infos_from_consensus_content (c : consensus_content) =\n let level = Raw_level_repr.to_int32 c.level in\n match Round_repr.to_int c.round with\n | Ok round -> {level; round}\n | Error _ -> {level; round = -1}\n\n(** Compute a {!endorsement_infos} from a {!consensus_content}. It is\n used to compute the weight of {!Endorsement} and {!Preendorsement}.\n\n Precondition: [c] comes from a valid operation. The {!Endorsement}\n or {!Preendorsement} is valid, so its [round] must succeed to\n convert into an {!int}. Hence, for the unreachable path where the\n convertion fails, we put (-1) as [round] value (see\n {!round_infos_from_consensus_content}). *)\nlet endorsement_infos_from_consensus_content (c : consensus_content) =\n let slot = Slot_repr.to_int c.slot in\n let round = round_infos_from_consensus_content c in\n {round; slot}\n\n(** Compute a {!double_baking_infos} and a {!Block_header_repr.hash}\n from a {!Block_header_repr.t}. It is used to compute the weight of\n a {!Double_baking_evidence}.\n\n Precondition: [bh] comes from a valid operation. The\n {!Double_baking_envidence} is valid, so its fitness from its first\n denounced block header must succeed, and the round from this\n fitness must convert in a {!int}. Hence, for the unreachable paths\n where either the convertion fails or the fitness is not\n retrievable, we put (-1) as [round] value. *)\nlet consensus_infos_and_hash_from_block_header (bh : Block_header_repr.t) =\n let level = bh.shell.level in\n let bh_hash = Block_header_repr.hash bh in\n let round =\n match Fitness_repr.from_raw bh.shell.fitness with\n | Ok bh_fitness -> (\n match Round_repr.to_int (Fitness_repr.round bh_fitness) with\n | Ok round -> {level; round}\n | Error _ -> {level; round = -1})\n | Error _ -> {level; round = -1}\n in\n {round; bh_hash}\n\n(** The weight of an operation.\n\n Given an operation, its [weight] carries on static information that\n is used to compare it to an operation of the same pass.\n Operation weight are defined by validation pass.\n\n The [weight] of an {!Endorsement} or {!Preendorsement} depends on\n its {!endorsement_infos}.\n\n The [weight] of a {!Dal_attestation} depends on the pair of\n the size of its bitset, {!Dal_attestation_repr.t}, and the\n signature of its attestor {! Signature.Public_key_hash.t}.\n\n The [weight] of a voting operation depends on the pair of its\n [period] and [source].\n\n The [weight] of a {!Vdf_revelation} depends on its [solution].\n\n The [weight] of a {!Seed_nonce_revelation} depends on its [level]\n converted in {!int32}.\n\n The [weight] of a {!Double_preendorsement} or\n {!Double_endorsement} depends on the [level] and [round] of their\n first denounciated operations. The [level] and [round] are wrapped\n in a {!round_infos}.\n\n The [weight] of a {!Double_baking} depends on the [level], [round]\n and [hash] of its first denounciated block_header. the [level] and\n [round] are wrapped in a {!double_baking_infos}.\n\n The [weight] of an {!Activate_account} depends on its public key\n hash.\n\n The [weight] of an {!Drain_delegate} depends on the public key\n hash of the delegate.\n\n The [weight] of {!Manager_operation} depends on its [fee] and\n [gas_limit] ratio expressed in {!Q.t}. *)\ntype _ weight =\n | Weight_endorsement : endorsement_infos -> consensus_pass_type weight\n | Weight_preendorsement : endorsement_infos -> consensus_pass_type weight\n | Weight_dal_attestation :\n (* attestor * num_attestations * level *)\n (Signature.Public_key_hash.t * int * int32)\n -> consensus_pass_type weight\n | Weight_proposals :\n int32 * Signature.Public_key_hash.t\n -> voting_pass_type weight\n | Weight_ballot :\n int32 * Signature.Public_key_hash.t\n -> voting_pass_type weight\n | Weight_seed_nonce_revelation : int32 -> anonymous_pass_type weight\n | Weight_vdf_revelation : Seed_repr.vdf_solution -> anonymous_pass_type weight\n | Weight_double_preendorsement : round_infos -> anonymous_pass_type weight\n | Weight_double_endorsement : round_infos -> anonymous_pass_type weight\n | Weight_double_baking : double_baking_infos -> anonymous_pass_type weight\n | Weight_activate_account :\n Ed25519.Public_key_hash.t\n -> anonymous_pass_type weight\n | Weight_drain_delegate :\n Signature.Public_key_hash.t\n -> anonymous_pass_type weight\n | Weight_manager : Q.t * Signature.public_key_hash -> manager_pass_type weight\n | Weight_noop : noop_pass_type weight\n\n(** The weight of an operation is the pair of its pass and weight. *)\ntype operation_weight = W : 'pass pass * 'pass weight -> operation_weight\n\n(** The {!weight} of a batch of {!Manager_operation} depends on the\n sum of all [fee] and the sum of all [gas_limit].\n\n Precondition: [op] is a valid manager operation: its sum\n of accumulated [fee] must succeed. Hence, in the unreachable path where\n the [fee] sum fails, we put [Tez_repr.zero] as its value. *)\nlet cumulate_fee_and_gas_of_manager :\n type kind.\n kind Kind.manager contents_list ->\n Tez_repr.t * Gas_limit_repr.Arith.integral =\n fun op ->\n let add_without_error acc y =\n match Tez_repr.(acc +? y) with\n | Ok v -> v\n | Error _ -> (* This cannot happen *) acc\n in\n let rec loop :\n type kind. 'a -> 'b -> kind Kind.manager contents_list -> 'a * 'b =\n fun fees_acc gas_limit_acc -> function\n | Single (Manager_operation {fee; gas_limit; _}) ->\n let total_fees = add_without_error fees_acc fee in\n let total_gas_limit =\n Gas_limit_repr.Arith.add gas_limit_acc gas_limit\n in\n (total_fees, total_gas_limit)\n | Cons (Manager_operation {fee; gas_limit; _}, manops) ->\n let fees_acc = add_without_error fees_acc fee in\n let gas_limit_acc = Gas_limit_repr.Arith.add gas_limit gas_limit_acc in\n loop fees_acc gas_limit_acc manops\n in\n loop Tez_repr.zero Gas_limit_repr.Arith.zero op\n\n(** The {!weight} of a {!Manager_operation} as well as a batch of\n operations is the ratio in {!int64} between its [fee] and\n [gas_limit] as computed by\n {!cumulate_fee_and_gas_of_manager} converted in {!Q.t}.\n We assume that the manager operation valid, thus its gas limit can\n never be zero. We treat this case the same as gas_limit = 1 for the\n sake of simplicity.\n*)\nlet weight_manager :\n type kind.\n kind Kind.manager contents_list -> Q.t * Signature.public_key_hash =\n fun op ->\n let fee, glimit = cumulate_fee_and_gas_of_manager op in\n let source =\n match op with\n | Cons (Manager_operation {source; _}, _) -> source\n | Single (Manager_operation {source; _}) -> source\n in\n let fee_f = Q.of_int64 (Tez_repr.to_mutez fee) in\n if Gas_limit_repr.Arith.(glimit = Gas_limit_repr.Arith.zero) then\n (fee_f, source)\n else\n let gas_f = Q.of_bigint (Gas_limit_repr.Arith.integral_to_z glimit) in\n (Q.(fee_f / gas_f), source)\n\n(** Computing the {!operation_weight} of an operation. [weight_of\n (Failing_noop _)] is unreachable, for completness we define a\n Weight_noop which carrries no information. *)\nlet weight_of : packed_operation -> operation_weight =\n fun op ->\n let (Operation_data protocol_data) = op.protocol_data in\n match protocol_data.contents with\n | Single (Failing_noop _) -> W (Noop, Weight_noop)\n | Single (Preendorsement consensus_content) ->\n W\n ( Consensus,\n Weight_preendorsement\n (endorsement_infos_from_consensus_content consensus_content) )\n | Single (Endorsement consensus_content) ->\n W\n ( Consensus,\n Weight_endorsement\n (endorsement_infos_from_consensus_content consensus_content) )\n | Single (Dal_attestation Dal_attestation_repr.{attestor; attestation; level})\n ->\n W\n ( Consensus,\n Weight_dal_attestation\n ( attestor,\n Dal_attestation_repr.occupied_size_in_bits attestation,\n Raw_level_repr.to_int32 level ) )\n | Single (Proposals {period; source; _}) ->\n W (Voting, Weight_proposals (period, source))\n | Single (Ballot {period; source; _}) ->\n W (Voting, Weight_ballot (period, source))\n | Single (Seed_nonce_revelation {level; _}) ->\n W (Anonymous, Weight_seed_nonce_revelation (Raw_level_repr.to_int32 level))\n | Single (Vdf_revelation {solution}) ->\n W (Anonymous, Weight_vdf_revelation solution)\n | Single (Double_endorsement_evidence {op1; _}) -> (\n match op1.protocol_data.contents with\n | Single (Endorsement consensus_content) ->\n W\n ( Anonymous,\n Weight_double_endorsement\n (round_infos_from_consensus_content consensus_content) ))\n | Single (Double_preendorsement_evidence {op1; _}) -> (\n match op1.protocol_data.contents with\n | Single (Preendorsement consensus_content) ->\n W\n ( Anonymous,\n Weight_double_preendorsement\n (round_infos_from_consensus_content consensus_content) ))\n | Single (Double_baking_evidence {bh1; _}) ->\n let double_baking_infos =\n consensus_infos_and_hash_from_block_header bh1\n in\n W (Anonymous, Weight_double_baking double_baking_infos)\n | Single (Activate_account {id; _}) ->\n W (Anonymous, Weight_activate_account id)\n | Single (Drain_delegate {delegate; _}) ->\n W (Anonymous, Weight_drain_delegate delegate)\n | Single (Manager_operation _) as ops ->\n let manweight, src = weight_manager ops in\n W (Manager, Weight_manager (manweight, src))\n | Cons (Manager_operation _, _) as ops ->\n let manweight, src = weight_manager ops in\n W (Manager, Weight_manager (manweight, src))\n\n(** {3 Comparisons of operations {!weight}} *)\n\n(** {4 Helpers} *)\n\n(** compare a pair of elements in lexicographic order. *)\nlet compare_pair_in_lexico_order ~cmp_fst ~cmp_snd (a1, b1) (a2, b2) =\n let resa = cmp_fst a1 a2 in\n if Compare.Int.(resa <> 0) then resa else cmp_snd b1 b2\n\n(** compare in reverse order. *)\nlet compare_reverse (cmp : 'a -> 'a -> int) a b = cmp b a\n\n(** {4 Comparison of {!consensus_infos}} *)\n\n(** Two {!round_infos} compares as the pair of [level, round] in\n lexicographic order: the one with the greater [level] being the\n greater [round_infos]. When levels are the same, the one with the\n greater [round] being the better.\n\n The greater {!round_infos} is the farther to the current state\n when part of the weight of a valid consensus operation.\n\n The best {!round_infos} is the nearer to the current state when\n part of the weight of a valid denunciation.\n\n In both case, that is the greater according to the lexicographic\n order.\n\n Precondition: the {!round_infos} are from valid operation. They\n have been computed by either {!round_infos_from_consensus_content}\n or {!consensus_infos_and_hash_from_block_header}. Both input\n parameter from valid operations and put (-1) to the [round] in the\n unreachable path where the original round fails to convert in\n {!int}. *)\nlet compare_round_infos infos1 infos2 =\n compare_pair_in_lexico_order\n ~cmp_fst:Compare.Int32.compare\n ~cmp_snd:Compare.Int.compare\n (infos1.level, infos1.round)\n (infos2.level, infos2.round)\n\n(** When comparing {!Endorsement} to {!Preendorsement} or\n {!Double_endorsement_evidence} to {!Double_preendorsement}, in case\n of {!round_infos} equality, the position is relevant to compute the\n order. *)\ntype prioritized_position = Nopos | Fstpos | Sndpos\n\n(** Comparison of two {!round_infos} with priority in case of\n {!round_infos} equality. *)\nlet compare_round_infos_with_prioritized_position ~prioritized_position infos1\n infos2 =\n let cmp = compare_round_infos infos1 infos2 in\n if Compare.Int.(cmp <> 0) then cmp\n else match prioritized_position with Fstpos -> 1 | Sndpos -> -1 | Nopos -> 0\n\n(** When comparing consensus operation with {!endorsement_infos}, in\n case of equality of their {!round_infos}, either they are of the\n same kind and their [slot] have to be compared in the reverse\n order, otherwise the {!Endorsement} is better and\n [prioritized_position] gives its position. *)\nlet compare_prioritized_position_or_slot ~prioritized_position =\n match prioritized_position with\n | Nopos -> compare_reverse Compare.Int.compare\n | Fstpos -> fun _ _ -> 1\n | Sndpos -> fun _ _ -> -1\n\n(** Two {!endorsement_infos} are compared by their {!round_infos}.\n When their {!round_infos} are equal, they are compared according to\n their priority or their [slot], see\n {!compare_prioritized_position_or_slot} for more details. *)\nlet compare_endorsement_infos ~prioritized_position (infos1 : endorsement_infos)\n (infos2 : endorsement_infos) =\n compare_pair_in_lexico_order\n ~cmp_fst:compare_round_infos\n ~cmp_snd:(compare_prioritized_position_or_slot ~prioritized_position)\n (infos1.round, infos1.slot)\n (infos2.round, infos2.slot)\n\n(** Two {!double_baking_infos} are compared as their {!round_infos}.\n When their {!round_infos} are equal, they are compared as the\n hashes of their first denounced block header. *)\nlet compare_baking_infos infos1 infos2 =\n compare_pair_in_lexico_order\n ~cmp_fst:compare_round_infos\n ~cmp_snd:Block_hash.compare\n (infos1.round, infos1.bh_hash)\n (infos2.round, infos2.bh_hash)\n\n(** Two valid {!Dal_attestation} are compared in the\n lexicographic order of their pairs of bitsets size and attestor\n hash. *)\nlet compare_dal_attestation (attestor1, endorsements1, level1)\n (attestor2, endorsements2, level2) =\n compare_pair_in_lexico_order\n ~cmp_fst:\n (compare_pair_in_lexico_order\n ~cmp_fst:Compare.Int32.compare\n ~cmp_snd:Compare.Int.compare)\n ~cmp_snd:Signature.Public_key_hash.compare\n ((level1, endorsements1), attestor1)\n ((level2, endorsements2), attestor2)\n\n(** {4 Comparison of valid operations of the same validation pass} *)\n\n(** {5 Comparison of valid consensus operations} *)\n\n(** Comparing consensus operations by their [weight] uses the\n comparison on {!endorsement_infos} for {!Endorsement} and\n {!Preendorsement}: see {!endorsement_infos} for more details.\n\n {!Dal_attestation} is smaller than the other kinds of\n consensus operations. Two valid {!Dal_attestation} are\n compared by {!compare_dal_attestation}. *)\nlet compare_consensus_weight w1 w2 =\n match (w1, w2) with\n | Weight_endorsement infos1, Weight_endorsement infos2 ->\n compare_endorsement_infos ~prioritized_position:Nopos infos1 infos2\n | Weight_preendorsement infos1, Weight_preendorsement infos2 ->\n compare_endorsement_infos ~prioritized_position:Nopos infos1 infos2\n | Weight_endorsement infos1, Weight_preendorsement infos2 ->\n compare_endorsement_infos ~prioritized_position:Fstpos infos1 infos2\n | Weight_preendorsement infos1, Weight_endorsement infos2 ->\n compare_endorsement_infos ~prioritized_position:Sndpos infos1 infos2\n | ( Weight_dal_attestation (attestor1, size1, lvl1),\n Weight_dal_attestation (attestor2, size2, lvl2) ) ->\n compare_dal_attestation (attestor1, size1, lvl1) (attestor2, size2, lvl2)\n | Weight_dal_attestation _, (Weight_endorsement _ | Weight_preendorsement _)\n ->\n -1\n | (Weight_endorsement _ | Weight_preendorsement _), Weight_dal_attestation _\n ->\n 1\n\n(** {5 Comparison of valid voting operations} *)\n\n(** Two valid voting operations of the same kind are compared in the\n lexicographic order of their pair of [period] and [source]. When\n compared to each other, the {!Proposals} is better. *)\nlet compare_vote_weight w1 w2 =\n let cmp i1 source1 i2 source2 =\n compare_pair_in_lexico_order\n (i1, source1)\n (i2, source2)\n ~cmp_fst:Compare.Int32.compare\n ~cmp_snd:Signature.Public_key_hash.compare\n in\n match (w1, w2) with\n | Weight_proposals (i1, source1), Weight_proposals (i2, source2) ->\n cmp i1 source1 i2 source2\n | Weight_ballot (i1, source1), Weight_ballot (i2, source2) ->\n cmp i1 source1 i2 source2\n | Weight_ballot _, Weight_proposals _ -> -1\n | Weight_proposals _, Weight_ballot _ -> 1\n\n(** {5 Comparison of valid anonymous operations} *)\n\n(** Comparing two {!Double_endorsement_evidence}, or two\n {!Double_preendorsement_evidence}, or comparing them to each other\n is comparing their {!round_infos}, see {!compare_round_infos} for\n more details.\n\n Comparing two {!Double_baking_evidence} is comparing as their\n {!double_baking_infos}, see {!compare_double_baking_infos} for more\n details.\n\n Two {!Seed_nonce_revelation} are compared by their [level].\n\n Two {!Vdf_revelation} are compared by their [solution].\n\n Two {!Activate_account} are compared as their [id].\n\n When comparing different kind of anonymous operations, the order is\n as follows: {!Double_preendorsement_evidence} >\n {!Double_endorsement_evidence} > {!Double_baking_evidence} >\n {!Vdf_revelation} > {!Seed_nonce_revelation} > {!Activate_account}.\n *)\nlet compare_anonymous_weight w1 w2 =\n match (w1, w2) with\n | Weight_double_preendorsement infos1, Weight_double_preendorsement infos2 ->\n compare_round_infos infos1 infos2\n | Weight_double_preendorsement infos1, Weight_double_endorsement infos2 ->\n compare_round_infos_with_prioritized_position\n ~prioritized_position:Fstpos\n infos1\n infos2\n | Weight_double_endorsement infos1, Weight_double_preendorsement infos2 ->\n compare_round_infos_with_prioritized_position\n ~prioritized_position:Sndpos\n infos1\n infos2\n | Weight_double_endorsement infos1, Weight_double_endorsement infos2 ->\n compare_round_infos infos1 infos2\n | ( ( Weight_double_baking _ | Weight_seed_nonce_revelation _\n | Weight_vdf_revelation _ | Weight_activate_account _\n | Weight_drain_delegate _ ),\n (Weight_double_preendorsement _ | Weight_double_endorsement _) ) ->\n -1\n | ( (Weight_double_preendorsement _ | Weight_double_endorsement _),\n ( Weight_double_baking _ | Weight_seed_nonce_revelation _\n | Weight_vdf_revelation _ | Weight_activate_account _\n | Weight_drain_delegate _ ) ) ->\n 1\n | Weight_double_baking infos1, Weight_double_baking infos2 ->\n compare_baking_infos infos1 infos2\n | ( ( Weight_seed_nonce_revelation _ | Weight_vdf_revelation _\n | Weight_activate_account _ | Weight_drain_delegate _ ),\n Weight_double_baking _ ) ->\n -1\n | ( Weight_double_baking _,\n ( Weight_seed_nonce_revelation _ | Weight_vdf_revelation _\n | Weight_activate_account _ | Weight_drain_delegate _ ) ) ->\n 1\n | Weight_vdf_revelation solution1, Weight_vdf_revelation solution2 ->\n Seed_repr.compare_vdf_solution solution1 solution2\n | ( ( Weight_seed_nonce_revelation _ | Weight_activate_account _\n | Weight_drain_delegate _ ),\n Weight_vdf_revelation _ ) ->\n -1\n | ( Weight_vdf_revelation _,\n ( Weight_seed_nonce_revelation _ | Weight_activate_account _\n | Weight_drain_delegate _ ) ) ->\n 1\n | Weight_seed_nonce_revelation l1, Weight_seed_nonce_revelation l2 ->\n Compare.Int32.compare l1 l2\n | ( (Weight_activate_account _ | Weight_drain_delegate _),\n Weight_seed_nonce_revelation _ ) ->\n -1\n | ( Weight_seed_nonce_revelation _,\n (Weight_activate_account _ | Weight_drain_delegate _) ) ->\n 1\n | Weight_activate_account pkh1, Weight_activate_account pkh2 ->\n Ed25519.Public_key_hash.compare pkh1 pkh2\n | Weight_drain_delegate _, Weight_activate_account _ -> -1\n | Weight_activate_account _, Weight_drain_delegate _ -> 1\n | Weight_drain_delegate pkh1, Weight_drain_delegate pkh2 ->\n Signature.Public_key_hash.compare pkh1 pkh2\n\n(** {5 Comparison of valid {!Manager_operation}} *)\n\n(** Two {!Manager_operation} are compared in the lexicographic order\n of their pair of their [fee]/[gas] ratio -- as computed by\n {!weight_manager} -- and their [source]. *)\nlet compare_manager_weight weight1 weight2 =\n match (weight1, weight2) with\n | Weight_manager (manweight1, source1), Weight_manager (manweight2, source2)\n ->\n compare_pair_in_lexico_order\n (manweight1, source1)\n (manweight2, source2)\n ~cmp_fst:Compare.Q.compare\n ~cmp_snd:Signature.Public_key_hash.compare\n\n(** Two {!operation_weight} are compared by their [pass], see\n {!compare_inner_pass} for more details. When they have the same\n [pass], they are compared by their [weight]. *)\nlet compare_operation_weight w1 w2 =\n match (w1, w2) with\n | W (Consensus, w1), W (Consensus, w2) -> compare_consensus_weight w1 w2\n | W (Voting, w1), W (Voting, w2) -> compare_vote_weight w1 w2\n | W (Anonymous, w1), W (Anonymous, w2) -> compare_anonymous_weight w1 w2\n | W (Manager, w1), W (Manager, w2) -> compare_manager_weight w1 w2\n | W (pass1, _), W (pass2, _) -> compare_inner_pass pass1 pass2\n\n(** {3 Compare two valid operations} *)\n\n(** Two valid operations are compared as their {!operation_weight},\n see {!compare_operation_weight} for more details.\n\n When they are equal according to their {!operation_weight} comparison, they\n compare as their hash.\n Hence, [compare] returns [0] only when the hashes of both operations are\n equal.\n\n Preconditions: [oph1] is the hash of [op1]; [oph2] the one of [op2]; and\n [op1] and [op2] are both valid. *)\nlet compare (oph1, op1) (oph2, op2) =\n let cmp_h = Operation_hash.(compare oph1 oph2) in\n if Compare.Int.(cmp_h = 0) then 0\n else\n let cmp = compare_operation_weight (weight_of op1) (weight_of op2) in\n if Compare.Int.(cmp = 0) then cmp_h else cmp\n" ;
} ;
{ name = "Manager_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(* Tezos Protocol Implementation - Low level Repr. of Managers' keys *)\n\n(** The public key of the manager of a contract is reveled only after the\n first operation. At Origination time, the manager provides only the hash\n of its public key that is stored in the contract. When the public key\n is actually revealed, the public key instead of the hash of the key *)\ntype manager_key =\n | Hash of Signature.Public_key_hash.t\n | Public_key of Signature.Public_key.t\n\ntype t = manager_key\n\nval encoding : t Data_encoding.encoding\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(* Tezos Protocol Implementation - Low level Repr. of Managers' keys *)\n\ntype manager_key =\n | Hash of Signature.Public_key_hash.t\n | Public_key of Signature.Public_key.t\n\ntype t = manager_key\n\nopen Data_encoding\n\nlet hash_case tag =\n case\n tag\n ~title:\"Public_key_hash\"\n Signature.Public_key_hash.encoding\n (function Hash hash -> Some hash | _ -> None)\n (fun hash -> Hash hash)\n\nlet pubkey_case tag =\n case\n tag\n ~title:\"Public_key\"\n Signature.Public_key.encoding\n (function Public_key hash -> Some hash | _ -> None)\n (fun hash -> Public_key hash)\n\nlet encoding = union [hash_case (Tag 0); pubkey_case (Tag 1)]\n" ;
} ;
{ name = "Commitment_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This type represents a commitment to an amount of tokens which can be claimed\n by a fund raiser after the blockchain is deployed. *)\ntype t = {\n blinded_public_key_hash : Blinded_public_key_hash.t;\n amount : Tez_repr.t;\n}\n\nval encoding : t Data_encoding.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t = {\n blinded_public_key_hash : Blinded_public_key_hash.t;\n amount : Tez_repr.t;\n}\n\nlet encoding =\n let open Data_encoding in\n conv\n (fun {blinded_public_key_hash; amount} -> (blinded_public_key_hash, amount))\n (fun (blinded_public_key_hash, amount) -> {blinded_public_key_hash; amount})\n (tup2 Blinded_public_key_hash.encoding Tez_repr.encoding)\n" ;
} ;
{ name = "Parameters_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module defines protocol parameters, i.e. constants regulating the\n behaviour of the blockchain under the protocol. *)\n\n(** An implict contract (account) initially existing on a chain since genesis. *)\ntype bootstrap_account = {\n public_key_hash : Signature.Public_key_hash.t;\n public_key : Signature.Public_key.t option;\n amount : Tez_repr.t;\n delegate_to : Signature.Public_key_hash.t option;\n consensus_key : Signature.Public_key.t option;\n}\n\n(** An originated contract initially existing on a chain since genesis. *)\ntype bootstrap_contract = {\n delegate : Signature.Public_key_hash.t option;\n amount : Tez_repr.t;\n script : Script_repr.t;\n}\n\n(** Protocol parameters define some constants regulating behaviour of the\n chain. *)\ntype t = {\n bootstrap_accounts : bootstrap_account list;\n bootstrap_contracts : bootstrap_contract list;\n commitments : Commitment_repr.t list;\n constants : Constants_parametric_repr.t;\n security_deposit_ramp_up_cycles : int option;\n no_reward_cycles : int option;\n}\n\nval bootstrap_account_encoding : bootstrap_account Data_encoding.t\n\nval encoding : t Data_encoding.t\n\nval check_params : t -> unit tzresult\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype bootstrap_account = {\n public_key_hash : Signature.Public_key_hash.t;\n public_key : Signature.Public_key.t option;\n amount : Tez_repr.t;\n delegate_to : Signature.Public_key_hash.t option;\n consensus_key : Signature.Public_key.t option;\n}\n\ntype bootstrap_contract = {\n delegate : Signature.Public_key_hash.t option;\n amount : Tez_repr.t;\n script : Script_repr.t;\n}\n\ntype t = {\n bootstrap_accounts : bootstrap_account list;\n bootstrap_contracts : bootstrap_contract list;\n commitments : Commitment_repr.t list;\n constants : Constants_parametric_repr.t;\n security_deposit_ramp_up_cycles : int option;\n no_reward_cycles : int option;\n}\n\nlet bootstrap_account_encoding =\n let open Data_encoding in\n union\n [\n case\n (Tag 0)\n ~title:\"Public_key_known\"\n (tup2 Signature.Public_key.encoding Tez_repr.encoding)\n (function\n | {\n public_key_hash;\n public_key = Some public_key;\n amount;\n delegate_to = None;\n consensus_key = None;\n } ->\n assert (\n Signature.Public_key_hash.equal\n (Signature.Public_key.hash public_key)\n public_key_hash) ;\n Some (public_key, amount)\n | {public_key = None; _}\n | {delegate_to = Some _; _}\n | {consensus_key = Some _; _} ->\n None)\n (fun (public_key, amount) ->\n {\n public_key = Some public_key;\n public_key_hash = Signature.Public_key.hash public_key;\n amount;\n delegate_to = None;\n consensus_key = None;\n });\n case\n (Tag 1)\n ~title:\"Public_key_unknown\"\n (tup2 Signature.Public_key_hash.encoding Tez_repr.encoding)\n (function\n | {\n public_key_hash;\n public_key = None;\n amount;\n delegate_to = None;\n consensus_key = None;\n } ->\n Some (public_key_hash, amount)\n | {public_key = Some _; _}\n | {delegate_to = Some _; _}\n | {consensus_key = Some _; _} ->\n None)\n (fun (public_key_hash, amount) ->\n {\n public_key = None;\n public_key_hash;\n amount;\n delegate_to = None;\n consensus_key = None;\n });\n case\n (Tag 2)\n ~title:\"Public_key_known_with_delegate\"\n (tup3\n Signature.Public_key.encoding\n Tez_repr.encoding\n Signature.Public_key_hash.encoding)\n (function\n | {\n public_key_hash;\n public_key = Some public_key;\n amount;\n delegate_to = Some delegate;\n consensus_key = None;\n } ->\n assert (\n Signature.Public_key_hash.equal\n (Signature.Public_key.hash public_key)\n public_key_hash) ;\n Some (public_key, amount, delegate)\n | {public_key = None; _}\n | {delegate_to = None; _}\n | {consensus_key = Some _; _} ->\n None)\n (fun (public_key, amount, delegate) ->\n {\n public_key = Some public_key;\n public_key_hash = Signature.Public_key.hash public_key;\n amount;\n delegate_to = Some delegate;\n consensus_key = None;\n });\n case\n (Tag 3)\n ~title:\"Public_key_unknown_with_delegate\"\n (tup3\n Signature.Public_key_hash.encoding\n Tez_repr.encoding\n Signature.Public_key_hash.encoding)\n (function\n | {\n public_key_hash;\n public_key = None;\n amount;\n delegate_to = Some delegate;\n consensus_key = None;\n } ->\n Some (public_key_hash, amount, delegate)\n | {public_key = Some _; _}\n | {delegate_to = None; _}\n | {consensus_key = Some _; _} ->\n None)\n (fun (public_key_hash, amount, delegate) ->\n {\n public_key = None;\n public_key_hash;\n amount;\n delegate_to = Some delegate;\n consensus_key = None;\n });\n case\n (Tag 4)\n ~title:\"Public_key_known_with_consensus_key\"\n (tup3\n Signature.Public_key.encoding\n Tez_repr.encoding\n Signature.Public_key.encoding)\n (function\n | {\n public_key_hash;\n public_key = Some public_key;\n amount;\n delegate_to = None;\n consensus_key = Some consensus_key;\n } ->\n assert (\n Signature.Public_key_hash.equal\n (Signature.Public_key.hash public_key)\n public_key_hash) ;\n Some (public_key, amount, consensus_key)\n | {public_key = None; _}\n | {delegate_to = Some _; _}\n | {consensus_key = None; _} ->\n None)\n (fun (public_key, amount, consensus_key) ->\n {\n public_key = Some public_key;\n public_key_hash = Signature.Public_key.hash public_key;\n amount;\n delegate_to = None;\n consensus_key = Some consensus_key;\n });\n ]\n\nlet bootstrap_contract_encoding =\n let open Data_encoding in\n conv\n (fun {delegate; amount; script} -> (delegate, amount, script))\n (fun (delegate, amount, script) -> {delegate; amount; script})\n (obj3\n (opt \"delegate\" Signature.Public_key_hash.encoding)\n (req \"amount\" Tez_repr.encoding)\n (req \"script\" Script_repr.encoding))\n\nlet encoding =\n let open Data_encoding in\n conv\n (fun {\n bootstrap_accounts;\n bootstrap_contracts;\n commitments;\n constants;\n security_deposit_ramp_up_cycles;\n no_reward_cycles;\n } ->\n ( ( bootstrap_accounts,\n bootstrap_contracts,\n commitments,\n security_deposit_ramp_up_cycles,\n no_reward_cycles ),\n constants ))\n (fun ( ( bootstrap_accounts,\n bootstrap_contracts,\n commitments,\n security_deposit_ramp_up_cycles,\n no_reward_cycles ),\n constants ) ->\n {\n bootstrap_accounts;\n bootstrap_contracts;\n commitments;\n constants;\n security_deposit_ramp_up_cycles;\n no_reward_cycles;\n })\n (merge_objs\n (obj5\n (req \"bootstrap_accounts\" (list bootstrap_account_encoding))\n (dft \"bootstrap_contracts\" (list bootstrap_contract_encoding) [])\n (dft \"commitments\" (list Commitment_repr.encoding) [])\n (opt \"security_deposit_ramp_up_cycles\" int31)\n (opt \"no_reward_cycles\" int31))\n Constants_parametric_repr.encoding)\n\nlet check_params params = Constants_repr.check_constants params.constants\n" ;
} ;
{ name = "Sapling_repr" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2019-2020 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype transaction = Sapling.UTXO.transaction\n\nlet transaction_encoding = Sapling.UTXO.transaction_encoding\n\n(* The two data structures in the state are all ordered by position, a diff\n contains the elements starting from an offset position up to the most recent\n position. A diff can be applied to a state stored in a context to obtain a\n new state.\n Diffs are used by the Michelson interpreter during the evaluation of smart\n contracts to keep a temporary state that may be discarded.\n Diffs are also returned by an RPC to allow a client to synchronize its own\n state with the chain.\n*)\ntype diff = {\n commitments_and_ciphertexts :\n (Sapling.Commitment.t * Sapling.Ciphertext.t) list;\n nullifiers : Sapling.Nullifier.t list;\n}\n\nlet diff_encoding =\n let open Data_encoding in\n conv\n (fun d -> (d.commitments_and_ciphertexts, d.nullifiers))\n (fun (commitments_and_ciphertexts, nullifiers) ->\n (match commitments_and_ciphertexts with\n | [] -> ()\n | (_cm_hd, ct_hd) :: rest ->\n let memo_size = Sapling.Ciphertext.get_memo_size ct_hd in\n List.iter\n (fun (_cm, ct) ->\n assert (\n Compare.Int.(Sapling.Ciphertext.get_memo_size ct = memo_size)))\n rest) ;\n {commitments_and_ciphertexts; nullifiers})\n (obj2\n (req\n \"commitments_and_ciphertexts\"\n (list (tup2 Sapling.Commitment.encoding Sapling.Ciphertext.encoding)))\n (req \"nullifiers\" (list Sapling.Nullifier.encoding)))\n\nmodule Memo_size = struct\n type t = int\n\n let encoding = Data_encoding.uint16\n\n let equal = Compare.Int.( = )\n\n let max_uint16 = 0xffff\n\n let max_uint16_z = Z.of_int max_uint16\n\n let err =\n Error\n (\"a positive 16-bit integer (between 0 and \" ^ string_of_int max_uint16\n ^ \")\")\n\n let parse_z z =\n if Compare.Z.(Z.zero <= z) && Compare.Z.(z <= max_uint16_z) then\n Ok (Z.to_int z)\n else err\n\n let unparse_to_z = Z.of_int\n\n let in_memory_size (_ : t) =\n let open Cache_memory_helpers in\n !!0\nend\n\nlet transaction_get_memo_size (transaction : Sapling.UTXO.transaction) =\n match transaction.outputs with\n | [] -> None\n | {ciphertext; _} :: _ ->\n (* Encoding ensures all ciphertexts have the same memo size. *)\n Some (Sapling.Ciphertext.get_memo_size ciphertext)\n\nopen Cache_memory_helpers\n\n(* This should be exported by [lib_sapling] rather than implemented here. *)\nlet input_in_memory_size =\n (* type input =\n * Sapling.UTXO.input = {\n * cv : Sapling.CV.t;\n * nf : Sapling.Nullifier.t;\n * rk : Sapling.UTXO.rk;\n * proof_i : Sapling.UTXO.spend_proof;\n * signature : Sapling.UTXO.spend_sig;\n * } *)\n let cv_size = string_size_gen 32 in\n let nf_size = string_size_gen 32 in\n let rk_size = string_size_gen 32 in\n let proof_i_size = string_size_gen @@ (48 + 96 + 48) in\n let signature_size = string_size_gen 64 in\n header_size +! (word_size *? 5) +! cv_size +! nf_size +! rk_size\n +! proof_i_size +! signature_size\n\nlet ciphertext_size =\n (* type t = {\n * cv : CV.t;\n * epk : DH.epk;\n * payload_enc : Bytes.t;\n * nonce_enc : Crypto_box.nonce;\n * payload_out : Bytes.t;\n * nonce_out : Crypto_box.nonce;\n * } *)\n let cv_size = string_size_gen 32 in\n let epk_size = string_size_gen 32 in\n let nonce_enc_size =\n string_size_gen 24\n (* from lib_hacl/hacl.ml:Nonce.size *)\n in\n let payload_out_size =\n string_size_gen (32 + 32 + 16)\n (* from lib_sapling/core.ml:Ciphertext.encoding *)\n in\n let nonce_out_size = string_size_gen 24 in\n let fixed_payload_data_size =\n 11 + 8 + 32 + 16 + 4\n (* from lib_sapling/core.ml:Ciphertext.get_memo_size *)\n in\n\n fun memo_size ->\n let payload_size = string_size_gen (memo_size + fixed_payload_data_size) in\n header_size +! (word_size *? 6) +! cv_size +! epk_size +! payload_size\n +! nonce_enc_size +! payload_out_size +! nonce_out_size\n\nlet output_in_memory_size =\n (* type output = {\n * cm : Commitment.t;\n * proof_o : output_proof;\n * ciphertext : Ciphertext.t;\n * } *)\n let cm_size = string_size_gen 32 in\n let proof_o_size = string_size_gen @@ (48 + 96 + 48) in\n let ciphertext_size = ciphertext_size in\n\n fun memo_size ->\n header_size +! (word_size *? 3) +! cm_size +! proof_o_size\n +! ciphertext_size memo_size\n\n(** Returns an approximation of the in-memory size of a Sapling transaction. *)\nlet transaction_in_memory_size (transaction : Sapling.UTXO.transaction) =\n (* type transaction =\n * transaction = {\n * inputs : Sapling.UTXO.input list;\n * outputs : Sapling.UTXO.output list;\n * binding_sig : Sapling.UTXO.binding_sig;\n * balance : int64;\n * root : Sapling.Hash.t;\n * } *)\n let binding_sig_size = string_size_gen 64 in\n let balance_size = int64_size in\n let root_size = string_size_gen 32 in\n let inputs = List.length transaction.inputs in\n let outputs = List.length transaction.outputs in\n let memo_size =\n Option.value ~default:0 (transaction_get_memo_size transaction)\n in\n let bound_data_size = string_size transaction.bound_data in\n header_size +! (word_size *? 5)\n +! (list_cell_size input_in_memory_size *? inputs)\n +! (list_cell_size (output_in_memory_size memo_size) *? outputs)\n +! binding_sig_size +! balance_size +! root_size +! bound_data_size\n\n(** Returns an approximation of the in-memory size of a Sapling diff. *)\nlet diff_in_memory_size ({commitments_and_ciphertexts; nullifiers} : diff) =\n let cms_and_cts = List.length commitments_and_ciphertexts in\n let nfs = List.length nullifiers in\n let cm_size = string_size_gen 32 in\n let nf_size = string_size_gen 32 in\n let memo_size =\n (* All memo_size in a diff should be equal (see invariant enforced by\n [diff] encoding above) *)\n match commitments_and_ciphertexts with\n | [] -> 0\n | (_, ct) :: _ -> Sapling.Ciphertext.get_memo_size ct\n in\n header_size +! (word_size *? 2)\n +! list_cell_size (boxed_tup2 cm_size (ciphertext_size memo_size))\n *? cms_and_cts\n +! (list_cell_size nf_size *? nfs)\n" ;
} ;
{ name = "Lazy_storage_kind" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2020 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(**\n Lazy_storage offers a unified interface for specific Michelson datatype that\n behave somewhat lazily, because they are intended to be quite big.\n Instead of serializing/deserializing the whole value to/from the storage,\n only an identifier is used. The identifier acts like a pointer.\n When using the value in a Michelson script, some part of it may be read from\n the storage, and a lightweight diff is computed.\n The diff is effectively applied to the storage at the end of the execution.\n\n This module defines the different kinds of lazy storages and their basic\n properties. See also [Lazy_storage_diff].\n\n Lazy storage types are:\n - Big_map\n*)\n\n(**\n Lazy storage ids are kept as abstract as possible to avoid mixing them up.\n\n Behind the scene they are [Z.t]s but, within the protocol, only [parse_data]/\n [unparse_data] are allowed convert from/to it.\n\n Temporary ids may be used to pass values between contracts that won't be kept\n longer than the lifetime of the operation.\n Behind the scene, temporary ids are negative [Z.t]s.\n*)\nmodule type ID = sig\n type t\n\n val compare : t -> t -> int\n\n val encoding : t Data_encoding.t\n\n val rpc_arg : t RPC_arg.arg\n\n (** Initial value for ids: zero. *)\n val init : t\n\n (** In the protocol, to be used in parse_data only *)\n val parse_z : Z.t -> t\n\n (** In the protocol, to be used in unparse_data only *)\n val unparse_to_z : t -> Z.t\n\n val next : t -> t\n\n val is_temp : t -> bool\n\n (* To be removed once legacy big map diff is removed: *)\n\n val of_legacy_USE_ONLY_IN_Legacy_big_map_diff : Z.t -> t\n\n val to_legacy_USE_ONLY_IN_Legacy_big_map_diff : t -> Z.t\n\n (* To be used in storage: *)\n\n include Path_encoding.S with type t := t\nend\n\nmodule Big_map : sig\n val title : string\n\n module Id : ID\n\n type alloc = {key_type : Script_repr.expr; value_type : Script_repr.expr}\n\n type update = {\n key : Script_repr.expr;\n (** The key is ignored by [apply_update] but is shown in the receipt,\n as specified in [print_big_map_diff]. *)\n key_hash : Script_expr_hash.t;\n value : Script_repr.expr option;\n }\n\n type updates = update list\n\n val alloc_encoding : alloc Data_encoding.t\n\n val updates_encoding : updates Data_encoding.t\nend\n\nmodule Sapling_state : sig\n val title : string\n\n module Id : ID\n\n type alloc = {memo_size : Sapling_repr.Memo_size.t}\n\n type updates = Sapling_repr.diff\n\n val alloc_encoding : alloc Data_encoding.t\n\n val updates_encoding : updates Data_encoding.t\nend\n\n(**\n Kinds of lazy storage.\n The GADT ensures operations are properly applied to the correct kind.\n\n ['id] the abstract type for the identifier of the kind.\n ['alloc] is the type used to construct a new value.\n ['updates] is the type used to update a value.\n*)\ntype ('id, 'alloc, 'updates) t =\n | Big_map : (Big_map.Id.t, Big_map.alloc, Big_map.updates) t\n | Sapling_state\n : (Sapling_state.Id.t, Sapling_state.alloc, Sapling_state.updates) t\n\ntype ex = Ex_Kind : (_, _, _) t -> ex\n\nval all : (int * ex) list\n\ntype (_, _) cmp = Eq : ('a, 'a) cmp | Neq\n\nval equal :\n ('i1, 'a1, 'u1) t ->\n ('i2, 'a2, 'u2) t ->\n ('i1 * 'a1 * 'u1, 'i2 * 'a2 * 'u2) cmp\n\ntype ('i, 'a, 'u) kind = ('i, 'a, 'u) t\n\n(**\n Type to manage temporary ids.\n Used only in the context.\n*)\nmodule Temp_ids : sig\n type t\n\n val init : t\n\n val fresh : ('i, 'a, 'u) kind -> t -> t * 'i\n\n val fold_s :\n ('i, 'a, 'u) kind -> ('acc -> 'i -> 'acc Lwt.t) -> t -> 'acc -> 'acc Lwt.t\nend\n\nmodule IdSet : sig\n type t\n\n type 'acc fold_f = {f : 'i 'a 'u. ('i, 'a, 'u) kind -> 'i -> 'acc -> 'acc}\n\n val empty : t\n\n val mem : ('i, 'a, 'u) kind -> 'i -> t -> bool\n\n val add : ('i, 'a, 'u) kind -> 'i -> t -> t\n\n val diff : t -> t -> t\n\n val fold : ('i, 'a, 'u) kind -> ('i -> 'acc -> 'acc) -> t -> 'acc -> 'acc\n\n val fold_all : 'acc fold_f -> t -> 'acc -> 'acc\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2020 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule type TEMP_ID = sig\n type t\n\n val equal : t -> t -> bool\n\n val init : t\n\n val next : t -> t\nend\n\nmodule type ID = sig\n type t\n\n val compare : t -> t -> int\n\n val encoding : t Data_encoding.t\n\n val rpc_arg : t RPC_arg.arg\n\n val init : t\n\n (** In the protocol, to be used in parse_data only *)\n val parse_z : Z.t -> t\n\n (** In the protocol, to be used in unparse_data only *)\n val unparse_to_z : t -> Z.t\n\n val next : t -> t\n\n val is_temp : t -> bool\n\n val of_legacy_USE_ONLY_IN_Legacy_big_map_diff : Z.t -> t\n\n val to_legacy_USE_ONLY_IN_Legacy_big_map_diff : t -> Z.t\n\n include Path_encoding.S with type t := t\nend\n\nmodule type Title = sig\n val title : string\nend\n\nmodule type TitleWithId = sig\n val title : string\n\n module Id : ID\n\n module Temp_id : TEMP_ID with type t = private Id.t\n\n module IdSet : Set.S with type elt = Id.t\nend\n\nmodule MakeId (Title : Title) : TitleWithId = struct\n let title = Title.title\n\n let title_words = String.map (function '_' -> ' ' | c -> c) title\n\n let rpc_arg_error = Format.sprintf \"Cannot parse %s id\" title_words\n\n let description = Format.sprintf \"A %s identifier\" title_words\n\n let name = title ^ \"_id\"\n\n let encoding_title = String.capitalize_ascii title_words ^ \" identifier\"\n\n module Id = struct\n type t = Z.t\n\n let compare = Z.compare\n\n let encoding =\n Data_encoding.def name ~title:encoding_title ~description Data_encoding.z\n\n let rpc_arg =\n let construct = Z.to_string in\n let destruct hash =\n Result.catch_f (fun () -> Z.of_string hash) (fun _ -> rpc_arg_error)\n in\n RPC_arg.make ~descr:description ~name ~construct ~destruct ()\n\n let init = Z.zero\n\n let parse_z (z : Z.t) : t = z\n\n let unparse_to_z (z : t) : Z.t = z\n\n let next = Z.succ\n\n let of_legacy_USE_ONLY_IN_Legacy_big_map_diff (z : Z.t) : t = z\n\n let to_legacy_USE_ONLY_IN_Legacy_big_map_diff (z : t) : Z.t = z\n\n let is_temp z = Compare.Z.(z < Z.zero)\n\n let path_length = 1\n\n let to_path z l = Z.to_string z :: l\n\n let of_path = function\n | [] | _ :: _ :: _ -> None\n | [z] -> Some (Z.of_string z)\n end\n\n module Temp_id = struct\n type t = Id.t\n\n let equal = Z.equal\n\n let init = Z.of_int ~-1\n\n let next z = Z.sub z Z.one\n end\n\n module IdSet = Set.Make (Id)\nend\n\nmodule Big_map = struct\n include MakeId (struct\n let title = \"big_map\"\n end)\n\n type alloc = {key_type : Script_repr.expr; value_type : Script_repr.expr}\n\n type update = {\n key : Script_repr.expr;\n (** The key is ignored by [apply_update] but is shown in the receipt,\n as specified in [print_big_map_diff]. *)\n key_hash : Script_expr_hash.t;\n value : Script_repr.expr option;\n }\n\n type updates = update list\n\n let alloc_encoding =\n let open Data_encoding in\n conv\n (fun {key_type; value_type} -> (key_type, value_type))\n (fun (key_type, value_type) -> {key_type; value_type})\n (obj2\n (req \"key_type\" Script_repr.expr_encoding)\n (req \"value_type\" Script_repr.expr_encoding))\n\n let update_encoding =\n let open Data_encoding in\n conv\n (fun {key_hash; key; value} -> (key_hash, key, value))\n (fun (key_hash, key, value) -> {key_hash; key; value})\n (obj3\n (req \"key_hash\" Script_expr_hash.encoding)\n (req \"key\" Script_repr.expr_encoding)\n (opt \"value\" Script_repr.expr_encoding))\n\n let updates_encoding = Data_encoding.list update_encoding\nend\n\nmodule Sapling_state = struct\n include MakeId (struct\n let title = \"sapling_state\"\n end)\n\n type alloc = {memo_size : Sapling_repr.Memo_size.t}\n\n type updates = Sapling_repr.diff\n\n let alloc_encoding =\n let open Data_encoding in\n conv\n (fun {memo_size} -> memo_size)\n (fun memo_size -> {memo_size})\n (obj1 (req \"memo_size\" Sapling_repr.Memo_size.encoding))\n\n let updates_encoding = Sapling_repr.diff_encoding\nend\n\n(*\n When adding cases to this type, grep for [new lazy storage kind] in the code\n for locations to update.\n It must be:\n - the value [all] right below,\n - modules [Temp_ids], [IdSet] below,\n - the rest should be guided by type errors.\n*)\ntype ('id, 'alloc, 'updates) t =\n | Big_map : (Big_map.Id.t, Big_map.alloc, Big_map.updates) t\n | Sapling_state\n : (Sapling_state.Id.t, Sapling_state.alloc, Sapling_state.updates) t\n\ntype ex = Ex_Kind : (_, _, _) t -> ex\n\n(* /!\\ Don't forget to add new lazy storage kinds here. /!\\ *)\nlet all = [(0, Ex_Kind Big_map); (1, Ex_Kind Sapling_state)]\n\ntype (_, _) cmp = Eq : ('a, 'a) cmp | Neq\n\nlet equal :\n type i1 a1 u1 i2 a2 u2.\n (i1, a1, u1) t -> (i2, a2, u2) t -> (i1 * a1 * u1, i2 * a2 * u2) cmp =\n fun k1 k2 ->\n match (k1, k2) with\n | Big_map, Big_map -> Eq\n | Sapling_state, Sapling_state -> Eq\n | Big_map, _ -> Neq\n | _, Big_map -> Neq\n\ntype ('i, 'a, 'u) kind = ('i, 'a, 'u) t\n\nmodule Temp_ids = struct\n type t = {\n big_map : Big_map.Temp_id.t;\n sapling_state : Sapling_state.Temp_id.t;\n }\n\n let init =\n {big_map = Big_map.Temp_id.init; sapling_state = Sapling_state.Temp_id.init}\n\n let fresh : type i a u. (i, a, u) kind -> t -> t * i =\n fun kind temp_ids ->\n match kind with\n | Big_map ->\n let big_map = Big_map.Temp_id.next temp_ids.big_map in\n ({temp_ids with big_map}, (temp_ids.big_map :> Big_map.Id.t))\n | Sapling_state ->\n let sapling_state = Sapling_state.Temp_id.next temp_ids.sapling_state in\n ( {temp_ids with sapling_state},\n (temp_ids.sapling_state :> Sapling_state.Id.t) )\n\n let fold_s :\n type i a u.\n (i, a, u) kind -> ('acc -> i -> 'acc Lwt.t) -> t -> 'acc -> 'acc Lwt.t =\n fun kind f temp_ids acc ->\n let helper (type j) (module Temp_id : TEMP_ID with type t = j) ~last f =\n let rec aux acc id =\n if Temp_id.equal id last then Lwt.return acc\n else f acc id >>= fun acc -> aux acc (Temp_id.next id)\n in\n aux acc Temp_id.init\n in\n match kind with\n | Big_map ->\n helper\n (module Big_map.Temp_id)\n ~last:temp_ids.big_map\n (fun acc temp_id -> f acc (temp_id :> i))\n | Sapling_state ->\n helper\n (module Sapling_state.Temp_id)\n ~last:temp_ids.sapling_state\n (fun acc temp_id -> f acc (temp_id :> i))\nend\n\nmodule IdSet = struct\n type t = {big_map : Big_map.IdSet.t; sapling_state : Sapling_state.IdSet.t}\n\n type 'acc fold_f = {f : 'i 'a 'u. ('i, 'a, 'u) kind -> 'i -> 'acc -> 'acc}\n\n let empty =\n {big_map = Big_map.IdSet.empty; sapling_state = Sapling_state.IdSet.empty}\n\n let mem (type i a u) (kind : (i, a, u) kind) (id : i) set =\n match (kind, set) with\n | Big_map, {big_map; _} -> Big_map.IdSet.mem id big_map\n | Sapling_state, {sapling_state; _} ->\n Sapling_state.IdSet.mem id sapling_state\n\n let add (type i a u) (kind : (i, a, u) kind) (id : i) set =\n match (kind, set) with\n | Big_map, {big_map; _} ->\n let big_map = Big_map.IdSet.add id big_map in\n {set with big_map}\n | Sapling_state, {sapling_state; _} ->\n let sapling_state = Sapling_state.IdSet.add id sapling_state in\n {set with sapling_state}\n\n let diff set1 set2 =\n let big_map = Big_map.IdSet.diff set1.big_map set2.big_map in\n let sapling_state =\n Sapling_state.IdSet.diff set1.sapling_state set2.sapling_state\n in\n {big_map; sapling_state}\n\n let fold (type i a u) (kind : (i, a, u) kind) (f : i -> 'acc -> 'acc) set\n (acc : 'acc) =\n match (kind, set) with\n | Big_map, {big_map; _} -> Big_map.IdSet.fold f big_map acc\n | Sapling_state, {sapling_state; _} ->\n Sapling_state.IdSet.fold f sapling_state acc\n\n let fold_all f set acc =\n List.fold_left\n (fun acc (_, Ex_Kind kind) -> fold kind (f.f kind) set acc)\n acc\n all\nend\n" ;
} ;
{ name = "Receipt_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Places where tez can be found in the ledger's state. *)\ntype balance =\n | Contract of Contract_repr.t\n | Block_fees\n | Deposits of Signature.Public_key_hash.t\n | Nonce_revelation_rewards\n | Double_signing_evidence_rewards\n | Endorsing_rewards\n | Baking_rewards\n | Baking_bonuses\n | Storage_fees\n | Double_signing_punishments\n | Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool\n | Liquidity_baking_subsidies\n | Burned\n | Commitments of Blinded_public_key_hash.t\n | Bootstrap\n | Invoice\n | Initial_commitments\n | Minted\n | Frozen_bonds of Contract_repr.t * Bond_id_repr.t\n | Tx_rollup_rejection_punishments\n | Tx_rollup_rejection_rewards\n | Sc_rollup_refutation_punishments\n | Sc_rollup_refutation_rewards\n\n(** Compares two balances. *)\nval compare_balance : balance -> balance -> int\n\n(** A credit or debit of tez to a balance. *)\ntype balance_update = Debited of Tez_repr.t | Credited of Tez_repr.t\n\n(** An origin of a balance update *)\ntype update_origin =\n | Block_application (** Update from a block application *)\n | Protocol_migration (** Update from a protocol migration *)\n | Subsidy (** Update from an inflationary subsidy *)\n | Simulation (** Simulation of an operation **)\n\n(** Compares two origins. *)\nval compare_update_origin : update_origin -> update_origin -> int\n\n(** A list of balance updates. Duplicates may happen.\n For example, an entry of the form [(Rewards (b,c), Credited am, ...)]\n indicates that the balance of frozen rewards has been increased by [am]\n for baker [b] and cycle [c]. *)\ntype balance_updates = (balance * balance_update * update_origin) list\n\n(** The property [Json.destruct (Json.construct balance_updates) = balance_updates]\n does not always hold for [balance_updates_encoding] when [balance_updates]\n contains entries of the form [(_, _ Tez_repr.zero, _)]. This is because the\n [balance_update] [(_ Tez_repr.zero)] always decodes into [(Credited Tez_repr.zero)]. *)\nval balance_updates_encoding : balance_updates Data_encoding.t\n\n(** Group updates by (balance x origin), and remove zero-valued balances. *)\nval group_balance_updates : balance_updates -> balance_updates tzresult\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype balance =\n | Contract of Contract_repr.t\n | Block_fees\n | Deposits of Signature.Public_key_hash.t\n | Nonce_revelation_rewards\n | Double_signing_evidence_rewards\n | Endorsing_rewards\n | Baking_rewards\n | Baking_bonuses\n | Storage_fees\n | Double_signing_punishments\n | Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool\n | Liquidity_baking_subsidies\n | Burned\n | Commitments of Blinded_public_key_hash.t\n | Bootstrap\n | Invoice\n | Initial_commitments\n | Minted\n | Frozen_bonds of Contract_repr.t * Bond_id_repr.t\n | Tx_rollup_rejection_punishments\n | Tx_rollup_rejection_rewards\n | Sc_rollup_refutation_punishments\n | Sc_rollup_refutation_rewards\n\nlet balance_encoding =\n let open Data_encoding in\n def \"operation_metadata.alpha.balance\"\n @@ union\n [\n case\n (Tag 0)\n ~title:\"Contract\"\n (obj2\n (req \"kind\" (constant \"contract\"))\n (req \"contract\" Contract_repr.encoding))\n (function Contract c -> Some ((), c) | _ -> None)\n (fun ((), c) -> Contract c);\n case\n (Tag 2)\n ~title:\"Block_fees\"\n (obj2\n (req \"kind\" (constant \"accumulator\"))\n (req \"category\" (constant \"block fees\")))\n (function Block_fees -> Some ((), ()) | _ -> None)\n (fun ((), ()) -> Block_fees);\n case\n (Tag 4)\n ~title:\"Deposits\"\n (obj3\n (req \"kind\" (constant \"freezer\"))\n (req \"category\" (constant \"deposits\"))\n (req \"delegate\" Signature.Public_key_hash.encoding))\n (function Deposits d -> Some ((), (), d) | _ -> None)\n (fun ((), (), d) -> Deposits d);\n case\n (Tag 5)\n ~title:\"Nonce_revelation_rewards\"\n (obj2\n (req \"kind\" (constant \"minted\"))\n (req \"category\" (constant \"nonce revelation rewards\")))\n (function Nonce_revelation_rewards -> Some ((), ()) | _ -> None)\n (fun ((), ()) -> Nonce_revelation_rewards);\n case\n (Tag 6)\n ~title:\"Double_signing_evidence_rewards\"\n (obj2\n (req \"kind\" (constant \"minted\"))\n (req \"category\" (constant \"double signing evidence rewards\")))\n (function\n | Double_signing_evidence_rewards -> Some ((), ()) | _ -> None)\n (fun ((), ()) -> Double_signing_evidence_rewards);\n case\n (Tag 7)\n ~title:\"Endorsing_rewards\"\n (obj2\n (req \"kind\" (constant \"minted\"))\n (req \"category\" (constant \"endorsing rewards\")))\n (function Endorsing_rewards -> Some ((), ()) | _ -> None)\n (fun ((), ()) -> Endorsing_rewards);\n case\n (Tag 8)\n ~title:\"Baking_rewards\"\n (obj2\n (req \"kind\" (constant \"minted\"))\n (req \"category\" (constant \"baking rewards\")))\n (function Baking_rewards -> Some ((), ()) | _ -> None)\n (fun ((), ()) -> Baking_rewards);\n case\n (Tag 9)\n ~title:\"Baking_bonuses\"\n (obj2\n (req \"kind\" (constant \"minted\"))\n (req \"category\" (constant \"baking bonuses\")))\n (function Baking_bonuses -> Some ((), ()) | _ -> None)\n (fun ((), ()) -> Baking_bonuses);\n case\n (Tag 11)\n ~title:\"Storage_fees\"\n (obj2\n (req \"kind\" (constant \"burned\"))\n (req \"category\" (constant \"storage fees\")))\n (function Storage_fees -> Some ((), ()) | _ -> None)\n (fun ((), ()) -> Storage_fees);\n case\n (Tag 12)\n ~title:\"Double_signing_punishments\"\n (obj2\n (req \"kind\" (constant \"burned\"))\n (req \"category\" (constant \"punishments\")))\n (function Double_signing_punishments -> Some ((), ()) | _ -> None)\n (fun ((), ()) -> Double_signing_punishments);\n case\n (Tag 13)\n ~title:\"Lost_endorsing_rewards\"\n (obj5\n (req \"kind\" (constant \"burned\"))\n (req \"category\" (constant \"lost endorsing rewards\"))\n (req \"delegate\" Signature.Public_key_hash.encoding)\n (req \"participation\" Data_encoding.bool)\n (req \"revelation\" Data_encoding.bool))\n (function\n | Lost_endorsing_rewards (d, p, r) -> Some ((), (), d, p, r)\n | _ -> None)\n (fun ((), (), d, p, r) -> Lost_endorsing_rewards (d, p, r));\n case\n (Tag 14)\n ~title:\"Liquidity_baking_subsidies\"\n (obj2\n (req \"kind\" (constant \"minted\"))\n (req \"category\" (constant \"subsidy\")))\n (function Liquidity_baking_subsidies -> Some ((), ()) | _ -> None)\n (fun ((), ()) -> Liquidity_baking_subsidies);\n case\n (Tag 15)\n ~title:\"Burned\"\n (obj2\n (req \"kind\" (constant \"burned\"))\n (req \"category\" (constant \"burned\")))\n (function Burned -> Some ((), ()) | _ -> None)\n (fun ((), ()) -> Burned);\n case\n (Tag 16)\n ~title:\"Commitments\"\n (obj3\n (req \"kind\" (constant \"commitment\"))\n (req \"category\" (constant \"commitment\"))\n (req \"committer\" Blinded_public_key_hash.encoding))\n (function Commitments bpkh -> Some ((), (), bpkh) | _ -> None)\n (fun ((), (), bpkh) -> Commitments bpkh);\n case\n (Tag 17)\n ~title:\"Bootstrap\"\n (obj2\n (req \"kind\" (constant \"minted\"))\n (req \"category\" (constant \"bootstrap\")))\n (function Bootstrap -> Some ((), ()) | _ -> None)\n (fun ((), ()) -> Bootstrap);\n case\n (Tag 18)\n ~title:\"Invoice\"\n (obj2\n (req \"kind\" (constant \"minted\"))\n (req \"category\" (constant \"invoice\")))\n (function Invoice -> Some ((), ()) | _ -> None)\n (fun ((), ()) -> Invoice);\n case\n (Tag 19)\n ~title:\"Initial_commitments\"\n (obj2\n (req \"kind\" (constant \"minted\"))\n (req \"category\" (constant \"commitment\")))\n (function Initial_commitments -> Some ((), ()) | _ -> None)\n (fun ((), ()) -> Initial_commitments);\n case\n (Tag 20)\n ~title:\"Minted\"\n (obj2\n (req \"kind\" (constant \"minted\"))\n (req \"category\" (constant \"minted\")))\n (function Minted -> Some ((), ()) | _ -> None)\n (fun ((), ()) -> Minted);\n case\n (Tag 21)\n ~title:\"Frozen_bonds\"\n (obj4\n (req \"kind\" (constant \"freezer\"))\n (req \"category\" (constant \"bonds\"))\n (req \"contract\" Contract_repr.encoding)\n (req \"bond_id\" Bond_id_repr.encoding))\n (function Frozen_bonds (c, r) -> Some ((), (), c, r) | _ -> None)\n (fun ((), (), c, r) -> Frozen_bonds (c, r));\n case\n (Tag 22)\n ~title:\"Tx_rollup_rejection_rewards\"\n (obj2\n (req \"kind\" (constant \"minted\"))\n (req \"category\" (constant \"tx_rollup_rejection_rewards\")))\n (function Tx_rollup_rejection_rewards -> Some ((), ()) | _ -> None)\n (fun ((), ()) -> Tx_rollup_rejection_rewards);\n case\n (Tag 23)\n ~title:\"Tx_rollup_rejection_punishments\"\n (obj2\n (req \"kind\" (constant \"burned\"))\n (req \"category\" (constant \"tx_rollup_rejection_punishments\")))\n (function\n | Tx_rollup_rejection_punishments -> Some ((), ()) | _ -> None)\n (fun ((), ()) -> Tx_rollup_rejection_punishments);\n case\n (Tag 24)\n ~title:\"Smart_rollup_refutation_punishments\"\n (obj2\n (req \"kind\" (constant \"burned\"))\n (req \"category\" (constant \"smart_rollup_refutation_punishments\")))\n (function\n | Sc_rollup_refutation_punishments -> Some ((), ()) | _ -> None)\n (fun ((), ()) -> Sc_rollup_refutation_punishments);\n case\n (Tag 25)\n ~title:\"Smart_rollup_refutation_rewards\"\n (obj2\n (req \"kind\" (constant \"minted\"))\n (req \"category\" (constant \"smart_rollup_refutation_rewards\")))\n (function\n | Sc_rollup_refutation_rewards -> Some ((), ()) | _ -> None)\n (fun ((), ()) -> Sc_rollup_refutation_rewards);\n ]\n\nlet is_not_zero c = not (Compare.Int.equal c 0)\n\nlet compare_balance ba bb =\n match (ba, bb) with\n | Contract ca, Contract cb -> Contract_repr.compare ca cb\n | Deposits pkha, Deposits pkhb -> Signature.Public_key_hash.compare pkha pkhb\n | Lost_endorsing_rewards (pkha, pa, ra), Lost_endorsing_rewards (pkhb, pb, rb)\n ->\n let c = Signature.Public_key_hash.compare pkha pkhb in\n if is_not_zero c then c\n else\n let c = Compare.Bool.compare pa pb in\n if is_not_zero c then c else Compare.Bool.compare ra rb\n | Commitments bpkha, Commitments bpkhb ->\n Blinded_public_key_hash.compare bpkha bpkhb\n | Frozen_bonds (ca, ra), Frozen_bonds (cb, rb) ->\n let c = Contract_repr.compare ca cb in\n if is_not_zero c then c else Bond_id_repr.compare ra rb\n | _, _ ->\n let index b =\n match b with\n | Contract _ -> 0\n | Block_fees -> 1\n | Deposits _ -> 2\n | Nonce_revelation_rewards -> 3\n | Double_signing_evidence_rewards -> 4\n | Endorsing_rewards -> 5\n | Baking_rewards -> 6\n | Baking_bonuses -> 7\n | Storage_fees -> 8\n | Double_signing_punishments -> 9\n | Lost_endorsing_rewards _ -> 10\n | Liquidity_baking_subsidies -> 11\n | Burned -> 12\n | Commitments _ -> 13\n | Bootstrap -> 14\n | Invoice -> 15\n | Initial_commitments -> 16\n | Minted -> 17\n | Frozen_bonds _ -> 18\n | Tx_rollup_rejection_punishments -> 19\n | Tx_rollup_rejection_rewards -> 20\n | Sc_rollup_refutation_punishments -> 21\n | Sc_rollup_refutation_rewards -> 22\n (* don't forget to add parameterized cases in the first part of the function *)\n in\n Compare.Int.compare (index ba) (index bb)\n\ntype balance_update = Debited of Tez_repr.t | Credited of Tez_repr.t\n\nlet is_zero_update = function Debited t | Credited t -> Tez_repr.(t = zero)\n\nlet balance_update_encoding =\n let open Data_encoding in\n def \"operation_metadata.alpha.balance_update\"\n @@ obj1\n (req\n \"change\"\n (conv\n (function\n | Credited v -> Tez_repr.to_mutez v\n | Debited v -> Int64.neg (Tez_repr.to_mutez v))\n ( Json.wrap_error @@ fun v ->\n if Compare.Int64.(v < 0L) then\n match Tez_repr.of_mutez (Int64.neg v) with\n | Some v -> Debited v\n | None -> assert false (* [of_mutez z] is [None] iff [z < 0] *)\n else\n match Tez_repr.of_mutez v with\n | Some v -> Credited v\n | None -> assert false (* same *) )\n int64))\n\ntype update_origin =\n | Block_application\n | Protocol_migration\n | Subsidy\n | Simulation\n\nlet compare_update_origin oa ob =\n let index o =\n match o with\n | Block_application -> 0\n | Protocol_migration -> 1\n | Subsidy -> 2\n | Simulation -> 3\n in\n Compare.Int.compare (index oa) (index ob)\n\nlet update_origin_encoding =\n let open Data_encoding in\n def \"operation_metadata.alpha.update_origin\"\n @@ obj1 @@ req \"origin\"\n @@ union\n [\n case\n (Tag 0)\n ~title:\"Block_application\"\n (constant \"block\")\n (function Block_application -> Some () | _ -> None)\n (fun () -> Block_application);\n case\n (Tag 1)\n ~title:\"Protocol_migration\"\n (constant \"migration\")\n (function Protocol_migration -> Some () | _ -> None)\n (fun () -> Protocol_migration);\n case\n (Tag 2)\n ~title:\"Subsidy\"\n (constant \"subsidy\")\n (function Subsidy -> Some () | _ -> None)\n (fun () -> Subsidy);\n case\n (Tag 3)\n ~title:\"Simulation\"\n (constant \"simulation\")\n (function Simulation -> Some () | _ -> None)\n (fun () -> Simulation);\n ]\n\ntype balance_updates = (balance * balance_update * update_origin) list\n\nlet balance_updates_encoding =\n let open Data_encoding in\n def \"operation_metadata.alpha.balance_updates\"\n @@ list\n (conv\n (function\n | balance, balance_update, update_origin ->\n ((balance, balance_update), update_origin))\n (fun ((balance, balance_update), update_origin) ->\n (balance, balance_update, update_origin))\n (merge_objs\n (merge_objs balance_encoding balance_update_encoding)\n update_origin_encoding))\n\nmodule BalanceMap = struct\n include Map.Make (struct\n type t = balance * update_origin\n\n let compare (ba, ua) (bb, ub) =\n let c = compare_balance ba bb in\n if is_not_zero c then c else compare_update_origin ua ub\n end)\n\n let update_r key (f : 'a option -> 'b option tzresult) map =\n f (find key map) >>? function\n | Some v -> ok (add key v map)\n | None -> ok (remove key map)\nend\n\nlet group_balance_updates balance_updates =\n List.fold_left_e\n (fun acc (b, update, o) ->\n (* Do not do anything if the update is zero *)\n if is_zero_update update then ok acc\n else\n BalanceMap.update_r\n (b, o)\n (function\n | None -> ok (Some update)\n | Some balance -> (\n match (balance, update) with\n | Credited a, Debited b | Debited b, Credited a ->\n (* Remove the binding since it just fell down to zero *)\n if Tez_repr.(a = b) then ok None\n else if Tez_repr.(a > b) then\n Tez_repr.(a -? b) >>? fun update ->\n ok (Some (Credited update))\n else\n Tez_repr.(b -? a) >>? fun update ->\n ok (Some (Debited update))\n | Credited a, Credited b ->\n Tez_repr.(a +? b) >>? fun update ->\n ok (Some (Credited update))\n | Debited a, Debited b ->\n Tez_repr.(a +? b) >>? fun update ->\n ok (Some (Debited update))))\n acc)\n BalanceMap.empty\n balance_updates\n >>? fun map ->\n ok (BalanceMap.fold (fun (b, o) u acc -> (b, u, o) :: acc) map [])\n" ;
} ;
{ name = "Migration_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Tocqueville Group, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Dupe of `Kind.origination successful_manager_operation_result` for use\n inside Alpha_context. Converted in Apply_results.\n\n Doesn't consume gas and omits lazy_storage_diff field since it would\n require copying Script_ir_translator functions to work on Raw_context.\n *)\ntype origination_result = {\n balance_updates : Receipt_repr.balance_updates;\n originated_contracts : Contract_hash.t list;\n storage_size : Z.t;\n paid_storage_size_diff : Z.t;\n}\n\nval origination_result_list_encoding : origination_result list Data_encoding.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Tocqueville Group, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype origination_result = {\n balance_updates : Receipt_repr.balance_updates;\n originated_contracts : Contract_hash.t list;\n storage_size : Z.t;\n paid_storage_size_diff : Z.t;\n}\n\nlet origination_result_list_encoding =\n let open Data_encoding in\n def \"operation.alpha.origination_result\"\n @@ list\n (conv\n (fun {\n balance_updates;\n originated_contracts;\n storage_size;\n paid_storage_size_diff;\n } ->\n ( balance_updates,\n originated_contracts,\n storage_size,\n paid_storage_size_diff ))\n (fun ( balance_updates,\n originated_contracts,\n storage_size,\n paid_storage_size_diff ) ->\n {\n balance_updates;\n originated_contracts;\n storage_size;\n paid_storage_size_diff;\n })\n (obj4\n (dft \"balance_updates\" Receipt_repr.balance_updates_encoding [])\n (dft\n \"originated_contracts\"\n (list Contract_repr.originated_encoding)\n [])\n (dft \"storage_size\" z Z.zero)\n (dft \"paid_storage_size_diff\" z Z.zero)))\n" ;
} ;
{ name = "Carbonated_map_costs" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021-2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** The type of the cost.*)\ntype cost = Saturation_repr.may_saturate Saturation_repr.t\n\n(** The [Carbonated_map_costs] module contains gas cost functions for\n [Carbonated_map].\n *)\n\n(** [find_cost ~compare_key_cost ~size] returns the gas cost for looking up an\n element from a map of size [size]. The user of this function is responsible\n for providing a correct value of [compare_key_cost], representing the cost\n of comparing elements with a given key.\n *)\nval find_cost : compare_key_cost:cost -> size:int -> cost\n\n(** [update_cost ~compare_key_cost ~size] returns the gas cost for updating an\n element in a map of size [size]. The user of this function is responsible\n for providing a correct value of [compare_key_cost], representing the cost\n of comparing elements with a given key. *)\nval update_cost : compare_key_cost:cost -> size:int -> cost\n\n(** [fold_cost ~size] returns the cost of folding over a list of size [size]. *)\nval fold_cost : size:int -> cost\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule S = Saturation_repr\nopen Gas_limit_repr\n\ntype cost = Saturation_repr.may_saturate Saturation_repr.t\n\n(** This is a good enough approximation *)\nlet log2 x = S.safe_int (1 + S.numbits x)\n\n(** Collect benchmark from [Carbonated_map_benchmarks.Find_benchmark].\n\n The model is similar to the gas model as from [Michelson_v1_gas.map_get].\n The user is responsible for providing the [compare_key_cost] which depends\n on the size of the [key]. See [Carbonated_map_benchmarks.Find_benchmark] for\n an example.\n The rational for the model is:\n - [intercept] is for paying a fixed cost regardless of size.\n - [compare_key_cost] is for the log2 of steps comparing keys\n - [traversal_overhead] is for the overhead of log2 steps walking the tree\n *)\nlet find_cost ~compare_key_cost ~size =\n let intercept = S.safe_int 50 in\n let size = S.safe_int size in\n let compare_cost = log2 size *@ compare_key_cost in\n let traversal_overhead = log2 size *@ S.safe_int 2 in\n intercept +@ compare_cost +@ traversal_overhead\n\n(**\n Modelling the precise overhead of update compared with [find] is tricky.\n The cost of [find] depends on the cost of comparing keys. When the tree\n is recreated, after looking up the element, this cost is no longer a factor.\n On the other hand, if the old map is no longer used, some nodes are going to\n be garbage collected at a later stage which incurs an extra cost.\n\n We here use the same model as in [Michelson_v1_gas.map_update]. That is\n providing an overestimate by doubling the cost of [find].\n *)\nlet update_cost ~compare_key_cost ~size =\n S.safe_int 2 *@ find_cost ~compare_key_cost ~size\n\n(** Collect benchmark from [Carbonated_map_benchmarks.Fold_benchmark].\n\n The cost of producing a list of elements is linear in the size of the map\n and does not depend on the size of the elements nor keys.\n*)\nlet fold_cost ~size = S.safe_int 50 +@ (S.safe_int 24 *@ S.safe_int size)\n" ;
} ;
{ name = "Carbonated_map" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021-2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** An in-memory data-structure for a key-value map where all operations\n account for gas costs.\n *)\n\nmodule type S = sig\n type 'a t\n\n (** The type of keys in the map. *)\n type key\n\n (** The type used for the context. *)\n type context\n\n (** [empty] an empty map. *)\n val empty : 'a t\n\n (** [singleton k v] returns a map with a single key [k] and value [v] pair. *)\n val singleton : key -> 'a -> 'a t\n\n (** [size m] returns the number of elements of the map [m] in constant time. *)\n val size : 'a t -> int\n\n (** [find ctxt k m] looks up the value with key [k] in the given map [m] and\n also consumes the gas associated with the lookup. The complexity is\n logarithmic in the size of the map. *)\n val find : context -> key -> 'a t -> ('a option * context) tzresult\n\n (** [update ctxt k f map] updates or adds the value of the key [k] using [f].\n The function accounts for the gas cost for finding the element. The updating\n function [f] should also account for its own gas cost. The complexity is\n logarithmic in the size of the map. *)\n val update :\n context ->\n key ->\n (context -> 'a option -> ('a option * context) tzresult) ->\n 'a t ->\n ('a t * context) tzresult\n\n (** [to_list m] transforms a map [m] into a list. It also accounts for the\n gas cost for traversing the elements. The complexity is linear in the size\n of the map. *)\n val to_list : context -> 'a t -> ((key * 'a) list * context) tzresult\n\n (** [of_list ctxt ~merge_overlaps m] creates a map from a list of key-value\n pairs. In case there are overlapping keys, their values are combined\n using the [merge_overlap] function. The function accounts for gas for\n traversing the elements. [merge_overlap] should account for its own gas\n cost. The complexity is [n * log n] in the size of the list.\n *)\n val of_list :\n context ->\n merge_overlap:(context -> 'a -> 'a -> ('a * context) tzresult) ->\n (key * 'a) list ->\n ('a t * context) tzresult\n\n (** [merge ctxt ~merge_overlap m1 m2] merges the maps [m1] and [m2]. In case\n there are overlapping keys, their values are combined using the\n [merge_overlap] function. Gas costs for traversing all elements from both\n maps are accounted for. [merge_overlap] should account for its own gas\n cost. The complexity is [n * log n], where [n]\n is [size m1 + size m2]. *)\n val merge :\n context ->\n merge_overlap:(context -> 'a -> 'a -> ('a * context) tzresult) ->\n 'a t ->\n 'a t ->\n ('a t * context) tzresult\n\n (** [map_e ctxt f m] maps over all key-value pairs in the map [m] using the\n function [f]. It accounts for gas costs associated with traversing the\n elements. The mapping function [f] should also account for its own gas\n cost. The complexity is linear in the size of the map [m]. *)\n val map_e :\n context ->\n (context -> key -> 'a -> ('b * context) tzresult) ->\n 'a t ->\n ('b t * context) tzresult\n\n (** [fold_e ctxt f z m] folds over the key-value pairs of the given map [m],\n accumulating values using [f], with [z] as the initial state. The function\n [f] must account for its own gas cost. The complexity is linear in the\n size of the map [m]. *)\n val fold_e :\n context ->\n (context -> 'state -> key -> 'value -> ('state * context) tzresult) ->\n 'state ->\n 'value t ->\n ('state * context) tzresult\n\n (** Lwt-aware variant of {!fold_e}. *)\n val fold_es :\n context ->\n (context -> 'state -> key -> 'value -> ('state * context) tzresult Lwt.t) ->\n 'state ->\n 'value t ->\n ('state * context) tzresult Lwt.t\nend\n\n(** This module is used to provide the function for consuming gas when\n constructing carbonated maps. *)\nmodule type GAS = sig\n (* The context type. *)\n type context\n\n (** [consume ctxt cost] returns a context where [cost] has been consumed. *)\n val consume :\n context ->\n Saturation_repr.may_saturate Saturation_repr.t ->\n context tzresult\nend\n\n(** Standard [Compare.COMPARE] extended with a [compare_cost] function\n specifying the cost for comparing values. *)\nmodule type COMPARABLE = sig\n include Compare.COMPARABLE\n\n (** [compare_cost k] returns the cost of comparing the given key [k] with\n another value of the same type. *)\n val compare_cost : t -> Saturation_repr.may_saturate Saturation_repr.t\nend\n\n(** A functor for exposing the type of a carbonated map before \n the carbonated make is created. This is useful in scenarios where \n the map that will need to be carbonated is defined before the \n gas consuming functions for the carbonation are available. \n See for example [Raw_context].\n*)\nmodule Make_builder (C : COMPARABLE) : sig\n type 'a t\n\n module Make (G : GAS) :\n S with type key = C.t and type context = G.context and type 'a t := 'a t\nend\n\n(** A functor for building gas metered maps. When building a gas metered map via\n [Make(G)(C)], [C] is a [COMPARABLE] required to construct a the map while\n [G] is a module providing the gas consuming functions. The type of the\n context on which the gas consuming function operates is\n determined by [G.context].\n*)\nmodule Make (G : GAS) (C : COMPARABLE) :\n S with type key = C.t and type context = G.context\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021-2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule type S = sig\n type 'a t\n\n type key\n\n type context\n\n val empty : 'a t\n\n val singleton : key -> 'a -> 'a t\n\n val size : 'a t -> int\n\n val find : context -> key -> 'a t -> ('a option * context) tzresult\n\n val update :\n context ->\n key ->\n (context -> 'a option -> ('a option * context) tzresult) ->\n 'a t ->\n ('a t * context) tzresult\n\n val to_list : context -> 'a t -> ((key * 'a) list * context) tzresult\n\n val of_list :\n context ->\n merge_overlap:(context -> 'a -> 'a -> ('a * context) tzresult) ->\n (key * 'a) list ->\n ('a t * context) tzresult\n\n val merge :\n context ->\n merge_overlap:(context -> 'a -> 'a -> ('a * context) tzresult) ->\n 'a t ->\n 'a t ->\n ('a t * context) tzresult\n\n val map_e :\n context ->\n (context -> key -> 'a -> ('b * context) tzresult) ->\n 'a t ->\n ('b t * context) tzresult\n\n val fold_e :\n context ->\n (context -> 'state -> key -> 'value -> ('state * context) tzresult) ->\n 'state ->\n 'value t ->\n ('state * context) tzresult\n\n val fold_es :\n context ->\n (context -> 'state -> key -> 'value -> ('state * context) tzresult Lwt.t) ->\n 'state ->\n 'value t ->\n ('state * context) tzresult Lwt.t\nend\n\nmodule type GAS = sig\n type context\n\n val consume :\n context ->\n Saturation_repr.may_saturate Saturation_repr.t ->\n context tzresult\nend\n\nmodule type COMPARABLE = sig\n include Compare.COMPARABLE\n\n (** [compare_cost k] returns the cost of comparing the given key [k] with\n another value of the same type. *)\n val compare_cost : t -> Saturation_repr.may_saturate Saturation_repr.t\nend\n\nmodule Make_builder (C : COMPARABLE) = struct\n module M = Map.Make (C)\n\n type 'a t = {map : 'a M.t; size : int}\n\n module Make (G : GAS) :\n S with type key = C.t and type context = G.context and type 'a t := 'a t =\n struct\n type key = C.t\n\n type context = G.context\n\n let empty = {map = M.empty; size = 0}\n\n let singleton key value = {map = M.singleton key value; size = 1}\n\n let size {size; _} = size\n\n let find_cost ~key ~size =\n Carbonated_map_costs.find_cost\n ~compare_key_cost:(C.compare_cost key)\n ~size\n\n let update_cost ~key ~size =\n Carbonated_map_costs.update_cost\n ~compare_key_cost:(C.compare_cost key)\n ~size\n\n let find ctxt key {map; size} =\n G.consume ctxt (find_cost ~key ~size) >|? fun ctxt ->\n (M.find key map, ctxt)\n\n let update ctxt key f {map; size} =\n let find_cost = find_cost ~key ~size in\n let update_cost = update_cost ~key ~size in\n (* Consume gas for looking up the old value *)\n G.consume ctxt find_cost >>? fun ctxt ->\n let old_val_opt = M.find key map in\n (* The call to [f] must also account for gas *)\n f ctxt old_val_opt >>? fun (new_val_opt, ctxt) ->\n match (old_val_opt, new_val_opt) with\n | Some _, Some new_val ->\n (* Consume gas for adding to the map *)\n G.consume ctxt update_cost >|? fun ctxt ->\n ({map = M.add key new_val map; size}, ctxt)\n | Some _, None ->\n (* Consume gas for removing from the map *)\n G.consume ctxt update_cost >|? fun ctxt ->\n ({map = M.remove key map; size = size - 1}, ctxt)\n | None, Some new_val ->\n (* Consume gas for adding to the map *)\n G.consume ctxt update_cost >|? fun ctxt ->\n ({map = M.add key new_val map; size = size + 1}, ctxt)\n | None, None -> ok ({map; size}, ctxt)\n\n let to_list ctxt {map; size} =\n G.consume ctxt (Carbonated_map_costs.fold_cost ~size) >|? fun ctxt ->\n (M.bindings map, ctxt)\n\n let add ctxt ~merge_overlap key value {map; size} =\n (* Consume gas for looking up the element *)\n G.consume ctxt (find_cost ~key ~size) >>? fun ctxt ->\n (* Consume gas for adding the element *)\n G.consume ctxt (update_cost ~key ~size) >>? fun ctxt ->\n match M.find key map with\n | Some old_val ->\n (* Invoking [merge_overlap] must also account for gas *)\n merge_overlap ctxt old_val value >|? fun (new_value, ctxt) ->\n ({map = M.add key new_value map; size}, ctxt)\n | None -> Ok ({map = M.add key value map; size = size + 1}, ctxt)\n\n let add_key_values_to_map ctxt ~merge_overlap map key_values =\n let accum (map, ctxt) (key, value) =\n add ctxt ~merge_overlap key value map\n in\n (* Gas is paid at each step of the fold. *)\n List.fold_left_e accum (map, ctxt) key_values\n\n let of_list ctxt ~merge_overlap =\n add_key_values_to_map ctxt ~merge_overlap empty\n\n let merge ctxt ~merge_overlap map1 {map; size} =\n (* To be on the safe side, pay an upfront gas cost for traversing the\n map. Each step of the fold is accounted for separately.\n *)\n G.consume ctxt (Carbonated_map_costs.fold_cost ~size) >>? fun ctxt ->\n M.fold_e\n (fun key value (map, ctxt) -> add ctxt ~merge_overlap key value map)\n map\n (map1, ctxt)\n\n let fold_e ctxt f empty {map; size} =\n G.consume ctxt (Carbonated_map_costs.fold_cost ~size) >>? fun ctxt ->\n M.fold_e\n (fun key value (acc, ctxt) ->\n (* Invoking [f] must also account for gas. *)\n f ctxt acc key value)\n map\n (empty, ctxt)\n\n let fold_es ctxt f empty {map; size} =\n G.consume ctxt (Carbonated_map_costs.fold_cost ~size) >>?= fun ctxt ->\n M.fold_es\n (fun key value (acc, ctxt) ->\n (* Invoking [f] must also account for gas. *)\n f ctxt acc key value)\n map\n (empty, ctxt)\n\n let map_e ctxt f {map; size} =\n (* We cannot use the standard map function because [f] also meters the gas\n cost at each invocation. *)\n fold_e\n ctxt\n (fun ctxt map key value ->\n (* Invoking [f] must also account for gas. *)\n f ctxt key value >>? fun (value, ctxt) ->\n (* Consume gas for adding the element. *)\n G.consume ctxt (update_cost ~key ~size) >|? fun ctxt ->\n (M.add key value map, ctxt))\n M.empty\n {map; size}\n >|? fun (map, ctxt) -> ({map; size}, ctxt)\n end\nend\n\nmodule Make (G : GAS) (C : COMPARABLE) :\n S with type key = C.t and type context = G.context = struct\n module M = Make_builder (C)\n\n type 'a t = 'a M.t\n\n include M.Make (G)\nend\n" ;
} ;
{ name = "Raw_context_intf" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2018-2021 Tarides <contact@tarides.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** All context manipulation functions. This signature is included\n as-is for direct context accesses, and used in {!Storage_functors}\n to provide restricted views to the context. *)\n\n(** The tree depth of a fold. See the [fold] function for more information. *)\ntype depth = [`Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int]\n\n(** The type for context configuration. If two trees or stores have the\n same configuration, they will generate the same context hash. *)\ntype config = Context.config\n\nmodule type VIEW = sig\n (* Same as [Environment_context.VIEW] but with extra getters and\n setters functions. *)\n\n (** The type for context views. *)\n type t\n\n (** The type for context keys. *)\n type key = string list\n\n (** The type for context values. *)\n type value = bytes\n\n (** The type for context trees. *)\n type tree\n\n (** {2 Getters} *)\n\n (** [mem t k] is an Lwt promise that resolves to [true] iff [k] is bound\n to a value in [t]. *)\n val mem : t -> key -> bool Lwt.t\n\n (** [mem_tree t k] is like {!mem} but for trees. *)\n val mem_tree : t -> key -> bool Lwt.t\n\n (** [get t k] is an Lwt promise that resolves to [Ok v] if [k] is\n bound to the value [v] in [t] and {!Storage_Error Missing_key}\n otherwise. *)\n val get : t -> key -> value tzresult Lwt.t\n\n (** [get_tree] is like {!get} but for trees. *)\n val get_tree : t -> key -> tree tzresult Lwt.t\n\n (** [find t k] is an Lwt promise that resolves to [Some v] if [k] is\n bound to the value [v] in [t] and [None] otherwise. *)\n val find : t -> key -> value option Lwt.t\n\n (** [find_tree t k] is like {!find} but for trees. *)\n val find_tree : t -> key -> tree option Lwt.t\n\n (** [list t key] is the list of files and sub-nodes stored under [k] in [t].\n The result order is not specified but is stable.\n\n [offset] and [length] are used for pagination. *)\n val list :\n t -> ?offset:int -> ?length:int -> key -> (string * tree) list Lwt.t\n\n (** {2 Setters} *)\n\n (** [init t k v] is an Lwt promise that resolves to [Ok c] if:\n\n - [k] is unbound in [t];\n - [k] is bound to [v] in [c];\n - and [c] is similar to [t] otherwise.\n\n It is {!Storage_error Existing_key} if [k] is already bound in [t]. *)\n val init : t -> key -> value -> t tzresult Lwt.t\n\n (** [init_tree] is like {!init} but for trees. *)\n val init_tree : t -> key -> tree -> t tzresult Lwt.t\n\n (** [update t k v] is an Lwt promise that resolves to [Ok c] if:\n\n - [k] is bound in [t];\n - [k] is bound to [v] in [c];\n - and [c] is similar to [t] otherwise.\n\n It is {!Storage_error Missing_key} if [k] is not already bound in [t]. *)\n val update : t -> key -> value -> t tzresult Lwt.t\n\n (** [update_tree] is like {!update} but for trees. *)\n val update_tree : t -> key -> tree -> t tzresult Lwt.t\n\n (** [add t k v] is an Lwt promise that resolves to [c] such that:\n\n - [k] is bound to [v] in [c];\n - and [c] is similar to [t] otherwise.\n\n If [k] was already bound in [t] to a value that is physically equal\n to [v], the result of the function is a promise that resolves to\n [t]. Otherwise, the previous binding of [k] in [t] disappears. *)\n val add : t -> key -> value -> t Lwt.t\n\n (** [add_tree] is like {!add} but for trees. *)\n val add_tree : t -> key -> tree -> t Lwt.t\n\n (** [remove t k v] is an Lwt promise that resolves to [c] such that:\n\n - [k] is unbound in [c];\n - and [c] is similar to [t] otherwise. *)\n val remove : t -> key -> t Lwt.t\n\n (** [remove_existing t k v] is an Lwt promise that resolves to [Ok c] if:\n\n - [k] is bound in [t] to a value;\n - [k] is unbound in [c];\n - and [c] is similar to [t] otherwise.*)\n val remove_existing : t -> key -> t tzresult Lwt.t\n\n (** [remove_existing_tree t k v] is an Lwt promise that reolves to [Ok c] if:\n\n - [k] is bound in [t] to a tree;\n - [k] is unbound in [c];\n - and [c] is similar to [t] otherwise.*)\n val remove_existing_tree : t -> key -> t tzresult Lwt.t\n\n (** [add_or_remove t k v] is:\n\n - [add t k x] if [v] is [Some x];\n - [remove t k] otherwise. *)\n val add_or_remove : t -> key -> value option -> t Lwt.t\n\n (** [add_or_remove_tree t k v] is:\n\n - [add_tree t k x] if [v] is [Some x];\n - [remove t k] otherwise. *)\n val add_or_remove_tree : t -> key -> tree option -> t Lwt.t\n\n (** {2 Folds} *)\n\n (** [fold ?depth t root ~order ~init ~f] recursively folds over the trees\n and values of [t]. The [f] callbacks are called with a key relative\n to [root]. [f] is never called with an empty key for values; i.e.,\n folding over a value is a no-op.\n\n The depth is 0-indexed. If [depth] is set (by default it is not), then [f]\n is only called when the conditions described by the parameter is true:\n\n - [Eq d] folds over nodes and values of depth exactly [d].\n - [Lt d] folds over nodes and values of depth strictly less than [d].\n - [Le d] folds over nodes and values of depth less than or equal to [d].\n - [Gt d] folds over nodes and values of depth strictly more than [d].\n - [Ge d] folds over nodes and values of depth more than or equal to [d].\n\n If [order] is [`Sorted] (the default), the elements are traversed in\n lexicographic order of their keys. For large nodes, it is memory-consuming,\n use [`Undefined] for a more memory efficient [fold]. *)\n val fold :\n ?depth:depth ->\n t ->\n key ->\n order:[`Sorted | `Undefined] ->\n init:'a ->\n f:(key -> tree -> 'a -> 'a Lwt.t) ->\n 'a Lwt.t\n\n (** {2 Hash configurations} *)\n\n (** [config t] is [t]'s hash configuration. *)\n val config : t -> config\n\n (** [length t key] is an Lwt promise that resolves to the number of files and\n sub-nodes stored under [k] in [t].\n\n It is equivalent to [list t k >|= List.length] but has a constant-time\n complexity.\n\n Most of the time, this function does not perform any I/O as the length is\n cached in the tree. It may perform one read to load the root node of the\n tree in case it has not been loaded already. The initial constant is the\n same between [list] and [length]. They both perform the same kind of I/O\n reads. While [list] usually performs a linear number of reads, [length]\n does at most one. *)\n val length : t -> key -> int Lwt.t\nend\n\nmodule Kind = struct\n type t = [`Value | `Tree]\nend\n\nmodule type TREE = sig\n (** [Tree] provides immutable, in-memory partial mirror of the\n context, with lazy reads and delayed writes. The trees are Merkle\n trees that carry the same hash as the part of the context they\n mirror.\n\n Trees are immutable and non-persistent (they disappear if the\n host crash), held in memory for efficiency, where reads are done\n lazily and writes are done only when needed, e.g. on\n [Context.commit]. If a key is modified twice, only the last\n value will be written to disk on commit. *)\n\n (** The type for context views. *)\n type t\n\n (** The type for context trees. *)\n type tree\n\n include VIEW with type t := tree and type tree := tree\n\n (** [empty _] is the empty tree. *)\n val empty : t -> tree\n\n (** [is_empty t] is true iff [t] is [empty _]. *)\n val is_empty : tree -> bool\n\n (** [kind t] is [t]'s kind. It's either a tree node or a leaf\n value. *)\n val kind : tree -> Kind.t\n\n (** [to_value t] is an Lwt promise that resolves to [Some v] if [t]\n is a leaf tree and [None] otherwise. It is equivalent to [find t\n []]. *)\n val to_value : tree -> value option Lwt.t\n\n (** [hash t] is [t]'s Merkle hash. *)\n val hash : tree -> Context_hash.t\n\n (** [equal x y] is true iff [x] and [y] have the same Merkle hash. *)\n val equal : tree -> tree -> bool\n\n (** {2 Caches} *)\n\n (** [clear ?depth t] clears all caches in the tree [t] for subtrees with a\n depth higher than [depth]. If [depth] is not set, all of the subtrees are\n cleared. *)\n val clear : ?depth:int -> tree -> unit\nend\n\nmodule type PROOF = sig\n (** Proofs are compact representations of trees which can be shared\n between peers.\n\n This is expected to be used as follows:\n\n - A first peer runs a function [f] over a tree [t]. While performing\n this computation, it records: the hash of [t] (called [before]\n below), the hash of [f t] (called [after] below) and a subset of [t]\n which is needed to replay [f] without any access to the first peer's\n storage. Once done, all these informations are packed into a proof of\n type [t] that is sent to the second peer.\n\n - The second peer generates an initial tree [t'] from [p] and computes\n [f t']. Once done, it compares [t']'s hash and [f t']'s hash to [before]\n and [after]. If they match, they know that the result state [f t'] is a\n valid context state, without having to have access to the full storage\n of the first peer. *)\n\n (** The type for file and directory names. *)\n type step = string\n\n (** The type for values. *)\n type value = bytes\n\n (** The type of indices for inodes' children. *)\n type index = int\n\n (** The type for hashes. *)\n type hash = Context_hash.t\n\n (** The type for (internal) inode proofs.\n\n These proofs encode large directories into a tree-like structure. This\n reflects irmin-pack's way of representing nodes and computing\n hashes (tree-like representations for nodes scales better than flat\n representations).\n\n [length] is the total number of entries in the children of the inode.\n It's the size of the \"flattened\" version of that inode. [length] can be\n used to prove the correctness of operations such [Tree.length] and\n [Tree.list ~offset ~length] in an efficient way.\n\n In proofs with [version.is_binary = false], an inode at depth 0 has a\n [length] of at least [257]. Below that threshold a [Node] tag is used in\n [tree]. That threshold is [3] when [version.is_binary = true].\n\n [proofs] contains the children proofs. It is a sparse list of ['a] values.\n These values are associated to their index in the list, and the list is\n kept sorted in increasing order of indices. ['a] can be a concrete proof\n or a hash of that proof.\n\n In proofs with [version.is_binary = true], inodes have at most 2 proofs\n (indexed 0 or 1).\n\n In proofs with [version.is_binary = false], inodes have at most 32 proofs\n (indexed from 0 to 31). *)\n type 'a inode = {length : int; proofs : (index * 'a) list}\n\n (** The type for inode extenders.\n\n An extender is a compact representation of a sequence of [inode] which\n contain only one child. As for inodes, The ['a] parameter can be a\n concrete proof or a hash of that proof.\n\n If an inode proof contains singleton children [i_0, ..., i_n] such as:\n [{length=l; proofs = [ (i_0, {proofs = ... { proofs = [ (i_n, p) ] }})]}],\n then it is compressed into the inode extender\n [{length=l; segment = [i_0;..;i_n]; proof=p}] sharing the same lenght [l]\n and final proof [p]. *)\n type 'a inode_extender = {length : int; segment : index list; proof : 'a}\n\n (** The type for compressed and partial Merkle tree proofs.\n\n Tree proofs do not provide any guarantee with the ordering of\n computations. For instance, if two effects commute, they won't be\n distinguishable by this kind of proofs.\n\n [Value v] proves that a value [v] exists in the store.\n\n [Blinded_value h] proves a value with hash [h] exists in the store.\n\n [Node ls] proves that a a \"flat\" node containing the list of files [ls]\n exists in the store.\n\n In proofs with [version.is_binary = true], the length of [ls] is at most\n 2.\n\n In proofs with [version.is_binary = false], the length of [ls] is at most\n 256.\n\n [Blinded_node h] proves that a node with hash [h] exists in the store.\n\n [Inode i] proves that an inode [i] exists in the store.\n\n [Extender e] proves that an inode extender [e] exist in the store. *)\n type tree =\n | Value of value\n | Blinded_value of hash\n | Node of (step * tree) list\n | Blinded_node of hash\n | Inode of inode_tree inode\n | Extender of inode_tree inode_extender\n\n (** The type for inode trees. It is a subset of [tree], limited to nodes.\n\n [Blinded_inode h] proves that an inode with hash [h] exists in the store.\n\n [Inode_values ls] is similar to trees' [Node].\n\n [Inode_tree i] is similar to tree's [Inode].\n\n [Inode_extender e] is similar to trees' [Extender]. *)\n and inode_tree =\n | Blinded_inode of hash\n | Inode_values of (step * tree) list\n | Inode_tree of inode_tree inode\n | Inode_extender of inode_tree inode_extender\n\n (** The type for kinded hashes. *)\n type kinded_hash = [`Value of hash | `Node of hash]\n\n module Stream : sig\n (** Stream proofs represent an explicit traversal of a Merle tree proof.\n Every element (a node, a value, or a shallow pointer) met is first\n \"compressed\" by shallowing its children and then recorded in the proof.\n\n As stream proofs directly encode the recursive construction of the\n Merkle root hash is slightly simpler to implement: verifier simply\n need to hash the compressed elements lazily, without any memory or\n choice.\n\n Moreover, the minimality of stream proofs is trivial to check.\n Once the computation has consumed the compressed elements required,\n it is sufficient to check that no more compressed elements remain\n in the proof.\n\n However, as the compressed elements contain all the hashes of their\n shallow children, the size of stream proofs is larger\n (at least double in size in practice) than tree proofs, which only\n contains the hash for intermediate shallow pointers. *)\n\n (** The type for elements of stream proofs.\n\n [Value v] is a proof that the next element read in the store is the\n value [v].\n\n [Node n] is a proof that the next element read in the store is the\n node [n].\n\n [Inode i] is a proof that the next element read in the store is the\n inode [i].\n\n [Inode_extender e] is a proof that the next element read in the store\n is the node extender [e]. *)\n type elt =\n | Value of value\n | Node of (step * kinded_hash) list\n | Inode of hash inode\n | Inode_extender of hash inode_extender\n\n (** The type for stream proofs.\n\n The sequence [e_1 ... e_n] proves that the [e_1], ..., [e_n] are\n read in the store in sequence. *)\n type t = elt Seq.t\n end\n\n type stream = Stream.t\n\n (** The type for proofs of kind ['a].\n\n A proof [p] proves that the state advanced from [before p] to\n [after p]. [state p]'s hash is [before p], and [state p] contains\n the minimal information for the computation to reach [after p].\n\n [version p] is the proof version, it packs several informations.\n\n [is_stream] discriminates between the stream proofs and the tree proofs.\n\n [is_binary] discriminates between proofs emitted from\n [Tezos_context(_memory).Context_binary] and\n [Tezos_context(_memory).Context].\n\n It will also help discriminate between the data encoding techniques used.\n\n The version is meant to be decoded and encoded using the\n {!Tezos_context_helpers.Context.decode_proof_version} and\n {!Tezos_context_helpers.Context.encode_proof_version}. *)\n type 'a t = {\n version : int;\n before : kinded_hash;\n after : kinded_hash;\n state : 'a;\n }\nend\n\nmodule type T = sig\n (** The type for root contexts. *)\n type root\n\n include VIEW\n\n module Tree :\n TREE\n with type t := t\n and type key := key\n and type value := value\n and type tree := tree\n\n module Proof : PROOF\n\n (** [verify p f] runs [f] in checking mode. [f] is a function that takes a\n tree as input and returns a new version of the tree and a result. [p] is a\n proof, that is a minimal representation of the tree that contains what [f]\n should be expecting.\n\n Therefore, contrary to trees found in a storage, the contents of the trees\n passed to [f] may not be available. For this reason, looking up a value at\n some [path] can now produce three distinct outcomes:\n - A value [v] is present in the proof [p] and returned : [find tree path]\n is a promise returning [Some v];\n - [path] is known to have no value in [tree] : [find tree path] is a\n promise returning [None]; and\n - [path] is known to have a value in [tree] but [p] does not provide it\n because [f] should not need it: [verify] returns an error classifying\n [path] as an invalid path (see below).\n\n The same semantics apply to all operations on the tree [t] passed to [f]\n and on all operations on the trees built from [f].\n\n The generated tree is the tree after [f] has completed. That tree is\n disconnected from any storage (i.e. [index]). It is possible to run\n operations on it as long as they don't require loading shallowed subtrees.\n\n The result is [Error (`Msg _)] if the proof is rejected:\n - For tree proofs: when [p.before] is different from the hash of\n [p.state];\n - For tree and stream proofs: when [p.after] is different from the hash\n of [f p.state];\n - For tree proofs: when [f p.state] tries to access invalid paths in\n [p.state];\n - For stream proofs: when the proof is not consumed in the exact same\n order it was produced;\n - For stream proofs: when the proof is too short or not empty once [f] is\n done.\n\n @raise Failure if the proof version is invalid or incompatible with the\n verifier. *)\n type ('proof, 'result) verifier :=\n 'proof ->\n (tree -> (tree * 'result) Lwt.t) ->\n ( tree * 'result,\n [ `Proof_mismatch of string\n | `Stream_too_long of string\n | `Stream_too_short of string ] )\n result\n Lwt.t\n\n (** The type for tree proofs.\n\n Guarantee that the given computation performs exactly the same state\n operations as the generating computation, *in some order*. *)\n type tree_proof := Proof.tree Proof.t\n\n (** [verify_tree_proof] is the verifier of tree proofs. *)\n val verify_tree_proof : (tree_proof, 'a) verifier\n\n (** The type for stream proofs.\n\n Guarantee that the given computation performs exactly the same state\n operations as the generating computation, in the exact same order. *)\n type stream_proof := Proof.stream Proof.t\n\n (** [verify_stream] is the verifier of stream proofs. *)\n val verify_stream_proof : (stream_proof, 'a) verifier\n\n (** The equality function for context configurations. If two context have the\n same configuration, they will generate the same context hashes. *)\n val equal_config : config -> config -> bool\n\n (** Internally used in {!Storage_functors} to escape from a view. *)\n val project : t -> root\n\n (** Internally used in {!Storage_functors} to retrieve a full key\n from partial key relative a view. *)\n val absolute_key : t -> key -> key\n\n (** Raised if block gas quota is exhausted during gas\n consumption. *)\n type error += Block_quota_exceeded\n\n (** Raised if operation gas quota is exhausted during gas\n consumption. *)\n type error += Operation_quota_exceeded\n\n (** Internally used in {!Storage_functors} to consume gas from\n within a view. May raise {!Block_quota_exceeded} or\n {!Operation_quota_exceeded}. *)\n val consume_gas : t -> Gas_limit_repr.cost -> t tzresult\n\n (** Check if consume_gas will fail *)\n val check_enough_gas : t -> Gas_limit_repr.cost -> unit tzresult\n\n val description : t Storage_description.t\n\n (** The type for local context accesses instead from the root. In order for\n the carbonated storage functions to consume the gas, this has gas\n infomation *)\n type local_context\n\n (**\n [with_local_context ctxt key f] runs function [f] over the local\n context at path [key] of the global [ctxt]. Using the local context [f]\n can perform faster context accesses under [key].\n *)\n val with_local_context :\n t ->\n key ->\n (local_context -> (local_context * 'a) tzresult Lwt.t) ->\n (t * 'a) tzresult Lwt.t\n\n (** [Local_context] provides functions for local access from a specific\n directory. *)\n module Local_context : sig\n include\n VIEW\n with type t = local_context\n and type tree := tree\n and type key := key\n and type value := value\n\n (** Internally used in {!Storage_functors} to consume gas from\n within a view. May raise {!Block_quota_exceeded} or\n {!Operation_quota_exceeded}. *)\n val consume_gas :\n local_context -> Gas_limit_repr.cost -> local_context tzresult\n\n (** Internally used in {!Storage_functors} to retrieve the full key of a\n partial key relative to the [local_context]. *)\n val absolute_key : local_context -> key -> key\n end\nend\n" ;
} ;
{ name = "Raw_context" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2022 Trili tech, Inc. <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** State of the validation.\n\n Two parts:\n\n 1. Context.t: what is stored between blocks, this includes an\n Irmin tree typically stored on disk and the cache (stored in\n RAM).\n\n 2. Additional information needed during the validation of a\n block but not persisted across blocks, always stored in\n RAM. The gas counter is here.\n\n [Alpha_context.t] is actually implemented as [Raw_context.t].\n The difference is that Alpha_context.mli does not expose this\n so functions manipulating an Alpha_context.t are guaranteed\n to only access the context through the storage modules\n exposed in Alpha_context.mli. These modules are in charge of\n maintaining invariants over the structure of the context. *)\n\n(** {1 Errors} *)\n\ntype error += Too_many_internal_operations (* `Permanent *)\n\ntype missing_key_kind = Get | Set | Del | Copy\n\n(** An internal storage error that should not happen *)\ntype storage_error =\n | Incompatible_protocol_version of string\n | Missing_key of string list * missing_key_kind\n | Existing_key of string list\n | Corrupted_data of string list\n\ntype error += Storage_error of storage_error\n\ntype error += Failed_to_parse_parameter of bytes\n\ntype error += Failed_to_decode_parameter of Data_encoding.json * string\n\nval storage_error : storage_error -> 'a tzresult\n\n(** {1 Abstract Context} *)\n\n(** Abstract view of the context.\n Includes a handle to the functional key-value database\n ({!Context.t}) along with some in-memory values (gas, etc.). *)\ntype t\n\ntype root = t\n\n(** Retrieves the state of the database and gives its abstract view.\n It also returns wether this is the first block validated\n with this version of the protocol. *)\nval prepare :\n level:Int32.t ->\n predecessor_timestamp:Time.t ->\n timestamp:Time.t ->\n Context.t ->\n t tzresult Lwt.t\n\ntype previous_protocol = Genesis of Parameters_repr.t | Lima_015\n\nval prepare_first_block :\n level:int32 ->\n timestamp:Time.t ->\n Context.t ->\n (previous_protocol * t) tzresult Lwt.t\n\nval activate : t -> Protocol_hash.t -> t Lwt.t\n\n(** Returns the state of the database resulting of operations on its\n abstract view *)\nval recover : t -> Context.t\n\nval current_level : t -> Level_repr.t\n\nval predecessor_timestamp : t -> Time.t\n\nval current_timestamp : t -> Time.t\n\nval constants : t -> Constants_parametric_repr.t\n\nval tx_rollup : t -> Constants_parametric_repr.tx_rollup\n\nval sc_rollup : t -> Constants_parametric_repr.sc_rollup\n\nval zk_rollup : t -> Constants_parametric_repr.zk_rollup\n\nval patch_constants :\n t -> (Constants_parametric_repr.t -> Constants_parametric_repr.t) -> t Lwt.t\n\nval round_durations : t -> Round_repr.Durations.t\n\n(** Retrieve the cycle eras. *)\nval cycle_eras : t -> Level_repr.cycle_eras\n\n(** Increment the current block fee stash that will be credited to the payload\n producer's account at finalize_application *)\nval credit_collected_fees_only_call_from_token : t -> Tez_repr.t -> t tzresult\n\n(** Decrement the current block fee stash that will be credited to the payload\n producer's account at finalize_application *)\nval spend_collected_fees_only_call_from_token : t -> Tez_repr.t -> t tzresult\n\n(** Returns the current block fee stash that will be credited to the payload\n producer's account at finalize_application *)\nval get_collected_fees : t -> Tez_repr.t\n\n(** [consume_gas_limit_in_block ctxt gas_limit] checks that\n [gas_limit] is well-formed (i.e. it does not exceed the hard gas\n limit per operation as defined in [ctxt], and it is positive), then\n consumes [gas_limit] in the current block gas level of [ctxt].\n\n @return [Error Gas_limit_repr.Gas_limit_too_high] if [gas_limit]\n is greater than the allowed limit for operation gas level or\n negative.\n\n @return [Error Block_quota_exceeded] if not enough gas remains in\n the block. *)\nval consume_gas_limit_in_block : t -> 'a Gas_limit_repr.Arith.t -> t tzresult\n\nval set_gas_limit : t -> 'a Gas_limit_repr.Arith.t -> t\n\nval set_gas_unlimited : t -> t\n\nval gas_level : t -> Gas_limit_repr.t\n\nval gas_consumed : since:t -> until:t -> Gas_limit_repr.Arith.fp\n\nval remaining_operation_gas : t -> Gas_limit_repr.Arith.fp\n\nval update_remaining_operation_gas : t -> Gas_limit_repr.Arith.fp -> t\n\nval block_gas_level : t -> Gas_limit_repr.Arith.fp\n\nval update_remaining_block_gas : t -> Gas_limit_repr.Arith.fp -> t\n\ntype error += Undefined_operation_nonce (* `Permanent *)\n\n(** [init_origination_nonce ctxt hash] initialise the origination nonce in\n memory from [hash]. See [Origination_nonce.t] for more information. *)\nval init_origination_nonce : t -> Operation_hash.t -> t\n\nval get_origination_nonce : t -> Origination_nonce.t tzresult\n\nval increment_origination_nonce : t -> (t * Origination_nonce.t) tzresult\n\n(** [unset_origination_nonce ctxt] unset the origination nonce in memory. To be\n used only when no more origination can be done in that operation. See\n [Origination_nonce.t] for more information. *)\nval unset_origination_nonce : t -> t\n\n(** {1 Generic accessors} *)\n\ntype key = string list\n\ntype value = bytes\n\ntype tree\n\ntype local_context\n\nmodule type T =\n Raw_context_intf.T\n with type root := root\n and type key := key\n and type value := value\n and type tree := tree\n\ninclude T with type t := t and type local_context := local_context\n\n(** Initialize the local nonce used for preventing a script to\n duplicate an internal operation to replay it. *)\nval reset_internal_nonce : t -> t\n\n(** Increments the internal operation nonce. *)\nval fresh_internal_nonce : t -> (t * int) tzresult\n\n(** Mark an internal operation nonce as taken. *)\nval record_internal_nonce : t -> int -> t\n\n(** Check is the internal operation nonce has been taken. *)\nval internal_nonce_already_recorded : t -> int -> bool\n\nval fold_map_temporary_lazy_storage_ids :\n t ->\n (Lazy_storage_kind.Temp_ids.t -> Lazy_storage_kind.Temp_ids.t * 'res) ->\n t * 'res\n\nval map_temporary_lazy_storage_ids_s :\n t ->\n (Lazy_storage_kind.Temp_ids.t -> (t * Lazy_storage_kind.Temp_ids.t) Lwt.t) ->\n t Lwt.t\n\nmodule Cache : sig\n include\n Context.CACHE\n with type t := t\n and type size := int\n and type index := int\n and type identifier := string\n and type key = Context.Cache.key\n and type value = Context.Cache.value\n\n val sync : t -> bytes -> t Lwt.t\nend\n\n(* Hashes of non-consensus operations are stored so that, when\n finalizing the block, we can compute the block's payload hash. *)\nval record_non_consensus_operation_hash : t -> Operation_hash.t -> t\n\nval non_consensus_operations : t -> Operation_hash.t list\n\ntype consensus_pk = {\n delegate : Signature.Public_key_hash.t;\n consensus_pk : Signature.Public_key.t;\n consensus_pkh : Signature.Public_key_hash.t;\n}\n\nval consensus_pk_encoding : consensus_pk Data_encoding.t\n\n(** Record that the dictator already voted in this block. *)\nval record_dictator_proposal_seen : t -> t\n\n(** Checks whether the dictator voted in this block. *)\nval dictator_proposal_seen : t -> bool\n\n(** [init_sampler_for_cycle ctxt cycle seed state] caches the seeded stake\n sampler (a.k.a. [seed, state]) for [cycle] in memory for quick access. *)\nval init_sampler_for_cycle :\n t -> Cycle_repr.t -> Seed_repr.seed -> consensus_pk Sampler.t -> t tzresult\n\n(** [sampler_for_cycle ~read ctxt cycle] returns the seeded stake\n sampler for [cycle]. The sampler is read in memory if\n [init_sampler_for_cycle] or [sampler_for_cycle] was previously\n called for the same [cycle]. Otherwise, it is read \"on-disk\" with\n the [read] function and then cached in [ctxt] like\n [init_sampler_for_cycle]. *)\nval sampler_for_cycle :\n read:(t -> (Seed_repr.seed * consensus_pk Sampler.t) tzresult Lwt.t) ->\n t ->\n Cycle_repr.t ->\n (t * Seed_repr.seed * consensus_pk Sampler.t) tzresult Lwt.t\n\n(* The stake distribution is stored both in [t] and in the cache. It\n may be sufficient to only store it in the cache. *)\nval stake_distribution_for_current_cycle :\n t -> Tez_repr.t Signature.Public_key_hash.Map.t tzresult\n\nval init_stake_distribution_for_current_cycle :\n t -> Tez_repr.t Signature.Public_key_hash.Map.t -> t\n\nmodule Internal_for_tests : sig\n val add_level : t -> int -> t\n\n val add_cycles : t -> int -> t\nend\n\nmodule type CONSENSUS = sig\n type t\n\n type 'value slot_map\n\n type slot_set\n\n type slot\n\n type round\n\n type consensus_pk\n\n (** Returns a map where each endorser's pkh is associated to the\n list of its endorsing slots (in decreasing order) for a given\n level. *)\n val allowed_endorsements : t -> (consensus_pk * int) slot_map\n\n (** Returns a map where each endorser's pkh is associated to the\n list of its endorsing slots (in decreasing order) for a given\n level. *)\n val allowed_preendorsements : t -> (consensus_pk * int) slot_map\n\n (** [endorsement power ctx] returns the endorsement power of the\n current block. *)\n val current_endorsement_power : t -> int\n\n (** Initializes the map of allowed endorsements and preendorsements,\n this function must be called only once and before applying\n any consensus operation. *)\n val initialize_consensus_operation :\n t ->\n allowed_endorsements:(consensus_pk * int) slot_map ->\n allowed_preendorsements:(consensus_pk * int) slot_map ->\n t\n\n (** [record_grand_parent_endorsement ctx pkh] records an\n grand_parent_endorsement for the current block. This is only\n useful for the partial construction mode. *)\n val record_grand_parent_endorsement :\n t -> Signature.Public_key_hash.t -> t tzresult\n\n (** [record_endorsement ctx ~initial_slot ~power] records an\n endorsement for the current block.\n\n The endorsement should be valid in the sense that\n [Int_map.find_opt initial_slot allowed_endorsement ctx = Some\n (pkh, power)]. *)\n val record_endorsement : t -> initial_slot:slot -> power:int -> t tzresult\n\n (** [record_preendorsement ctx ~initial_slot ~power round\n payload_hash power] records a preendorsement for a proposal at\n [round] with payload [payload_hash].\n\n The preendorsement should be valid in the sense that\n [Int_map.find_opt initial_slot allowed_preendorsement ctx = Some\n (pkh, power)]. *)\n val record_preendorsement :\n t -> initial_slot:slot -> power:int -> round -> t tzresult\n\n val endorsements_seen : t -> slot_set\n\n (** [get_preendorsements_quorum_round ctx] returns [None] if no\n preendorsement are included in the current block. Otherwise,\n return [Some r] where [r] is the round of the preendorsements\n included in the block. *)\n val get_preendorsements_quorum_round : t -> round option\n\n (** [set_preendorsements_quorum_round ctx round] sets the round for\n preendorsements included in this block. This function should be\n called only once.\n\n This function is only used in [Full_construction] mode. *)\n val set_preendorsements_quorum_round : t -> round -> t\n\n (** [locked_round_evidence ctx] returns the round of the recorded\n preendorsements as well as their power. *)\n val locked_round_evidence : t -> (round * int) option\n\n val set_endorsement_branch : t -> Block_hash.t * Block_payload_hash.t -> t\n\n val endorsement_branch : t -> (Block_hash.t * Block_payload_hash.t) option\n\n val set_grand_parent_branch : t -> Block_hash.t * Block_payload_hash.t -> t\n\n val grand_parent_branch : t -> (Block_hash.t * Block_payload_hash.t) option\nend\n\nmodule Consensus :\n CONSENSUS\n with type t := t\n and type slot := Slot_repr.t\n and type 'a slot_map := 'a Slot_repr.Map.t\n and type slot_set := Slot_repr.Set.t\n and type round := Round_repr.t\n and type consensus_pk := consensus_pk\n\nmodule Tx_rollup : sig\n val add_message :\n t ->\n Tx_rollup_repr.t ->\n Tx_rollup_message_hash_repr.t ->\n t * Tx_rollup_inbox_repr.Merkle.root\nend\n\nmodule Sc_rollup_in_memory_inbox : sig\n val current_messages : t -> Sc_rollup_inbox_merkelized_payload_hashes_repr.t\n\n val set_current_messages :\n t -> Sc_rollup_inbox_merkelized_payload_hashes_repr.t -> t\nend\n\nmodule Dal : sig\n (** [record_available_shards ctxt slots shards] records that the\n list of shards [shards] were declared available. The function\n assumes that a shard belongs to the interval [0; number_of_shards\n - 1]. Otherwise, for each shard outside this interval, it is a\n no-op. *)\n val record_available_shards : t -> Dal_attestation_repr.t -> int list -> t\n\n (** [register_slot_header ctxt slot_header] returns a new context\n where the new candidate [slot] have been taken into\n account. Returns [Some (ctxt,updated)] where [updated=true] if\n the candidate is registered. [Some (ctxt,false)] if another\n candidate was already registered previously. Returns an error if\n the slot is invalid. *)\n val register_slot_header : t -> Dal_slot_repr.Header.t -> (t * bool) tzresult\n\n (** [candidates ctxt] returns the current list of slot for which\n there is at least one candidate. *)\n val candidates : t -> Dal_slot_repr.Header.t list\n\n (** [is_slot_index_available ctxt slot_index] returns [true] if the\n [slot_index] is declared available by the protocol. [false]\n otherwise. If the [index] is out of the interval\n [0;number_of_slots - 1], returns [false]. *)\n val is_slot_index_available : t -> Dal_slot_repr.Index.t -> bool\n\n (** [shards_of_attestor ctxt ~attestor] returns the shard assignment\n of the DAL committee of the current level for [attestor]. This\n function never returns an empty list. *)\n val shards_of_attestor :\n t -> attestor:Signature.Public_key_hash.t -> int list option\n\n (** The DAL committee is a subset of the Tenderbake committee. A\n shard from [0;number_of_shards] is associated to a public key\n hash. For efficiency reasons, the committee is two-folds: a\n mapping public key hash to shards and shards to public key\n hashes. The DAL committee ensures the shards associated to the\n same public key hash are contiguous. The list of shards is\n represented as two natural numbers [(initial, power)] which\n encodes the list of shards:\n [initial;initial + 1;...;initial + power - 1].\n\n This data-type ensures the following invariants:\n\n - \\forall pkh shard, find pkh_to_shards pkh = Some (start,n) ->\n \\forall i, i \\in [start; start + n -1] -> find shard_to_pkh shard\n = Some pkh\n\n - forall pkh shard, find shard_to_pkh shard = Some pkh ->\n \\exists (start,n), find pkh_to_shards pkh = Some (start,n) /\\\n start <= shard <= start + n -1\n\n - Given an attestor, all its shards assignement are contiguous\n *)\n type committee = {\n pkh_to_shards :\n (Dal_attestation_repr.shard_index * int) Signature.Public_key_hash.Map.t;\n shard_to_pkh : Signature.Public_key_hash.t Dal_attestation_repr.Shard_map.t;\n }\n\n (** [compute_committee ctxt pkh_from_tenderbake_slot] computes the\n DAL committee using the [pkh_from_tenderbake_slot] function. This\n functions takes into account the fact that the DAL committee and\n the Tenderbake committee may have different size. If the DAL\n committee is smaller, then we simply take a projection of the\n Tenderbake committee for the first [n] slots. If the DAL\n committee is larger, shards are computed moduloe the Tenderbake\n committee. Slots assignements are reordered for a given a public\n key hash, to ensure all the slots (or shards in the context of\n DAL) shards are contiguous (see {!type:committee}). *)\n val compute_committee :\n t ->\n (Slot_repr.t -> (t * Signature.Public_key_hash.t) tzresult Lwt.t) ->\n committee tzresult Lwt.t\n\n (** [init_committee ctxt committee] returns a context where the\n [committee] is cached. The committee is expected to be the one\n for the current level. *)\n val init_committee : t -> committee -> t\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021-2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule Int_set = Set.Make (Compare.Int)\n\n(*\n\n Gas levels maintenance\n =======================\n\n The context maintains two levels of gas, one corresponds to the gas\n available for the current operation while the other is the gas\n available for the current block. Both levels are maintained\n independently: [consume_gas] only decreases the operation level,\n and block level should be updated with [consume_gas_limit_in_block].\n\n A layered context\n =================\n\n Updating the context [remaining_operation_gas] is a critical routine\n called very frequently by the operations performed by the protocol.\n On the contrary, other fields are less frequently updated.\n\n In a previous version of the context datatype definition, all\n the fields were represented at the toplevel. To update the remaining\n gas, we had to copy ~25 fields (that is 200 bytes).\n\n With the following layered representation, we only have to\n copy 2 fields (16 bytes) during [remaining_operation_gas] update.\n This has a significant impact on the Michelson runtime efficiency.\n\n Here are the fields on the [back] of the context:\n\n *)\n\ntype consensus_pk = {\n delegate : Signature.Public_key_hash.t;\n consensus_pk : Signature.Public_key.t;\n consensus_pkh : Signature.Public_key_hash.t;\n}\n\nlet consensus_pk_encoding =\n let open Data_encoding in\n conv\n (fun {delegate; consensus_pk; consensus_pkh} ->\n if Signature.Public_key_hash.equal consensus_pkh delegate then\n (consensus_pk, None)\n else (consensus_pk, Some delegate))\n (fun (consensus_pk, delegate) ->\n let consensus_pkh = Signature.Public_key.hash consensus_pk in\n let delegate =\n match delegate with None -> consensus_pkh | Some del -> del\n in\n {delegate; consensus_pk; consensus_pkh})\n (obj2\n (req \"consensus_pk\" Signature.Public_key.encoding)\n (opt \"delegate\" Signature.Public_key_hash.encoding))\n\nmodule Raw_consensus = struct\n (** Consensus operations are indexed by their [initial slots]. Given\n a delegate, the [initial slot] is the lowest slot assigned to\n this delegate. *)\n\n type t = {\n current_endorsement_power : int;\n (** Number of endorsement slots recorded for the current block. *)\n allowed_endorsements : (consensus_pk * int) Slot_repr.Map.t;\n (** Endorsements rights for the current block. Only an endorsement\n for the lowest slot in the block can be recorded. The map\n associates to each initial slot the [pkh] associated to this\n slot with its power. *)\n allowed_preendorsements : (consensus_pk * int) Slot_repr.Map.t;\n (** Preendorsements rights for the current block. Only a preendorsement\n for the lowest slot in the block can be recorded. The map\n associates to each initial slot the [pkh] associated to this\n slot with its power. *)\n grand_parent_endorsements_seen : Signature.Public_key_hash.Set.t;\n (** Record the endorsements already seen for the grand\n parent. This only useful for the partial construction mode. *)\n endorsements_seen : Slot_repr.Set.t;\n (** Record the endorsements already seen. Only initial slots are indexed. *)\n preendorsements_seen : Slot_repr.Set.t;\n (** Record the preendorsements already seen. Only initial slots\n are indexed. *)\n locked_round_evidence : (Round_repr.t * int) option;\n (** Record the preendorsement power for a locked round. *)\n preendorsements_quorum_round : Round_repr.t option;\n (** in block construction mode, record the round of preendorsements\n included in a block. *)\n endorsement_branch : (Block_hash.t * Block_payload_hash.t) option;\n grand_parent_branch : (Block_hash.t * Block_payload_hash.t) option;\n }\n\n (** Invariant:\n\n - [slot \\in endorsements_seen => Int_map.mem slot allowed_endorsements]\n\n - [slot \\in preendorsements_seen => Int_map.mem slot allowed_preendorsements]\n\n - [ |endorsements_seen| > 0 => |included endorsements| > 0]\n\n *)\n\n let empty : t =\n {\n current_endorsement_power = 0;\n allowed_endorsements = Slot_repr.Map.empty;\n allowed_preendorsements = Slot_repr.Map.empty;\n grand_parent_endorsements_seen = Signature.Public_key_hash.Set.empty;\n endorsements_seen = Slot_repr.Set.empty;\n preendorsements_seen = Slot_repr.Set.empty;\n locked_round_evidence = None;\n preendorsements_quorum_round = None;\n endorsement_branch = None;\n grand_parent_branch = None;\n }\n\n type error += Double_inclusion_of_consensus_operation\n\n let () =\n register_error_kind\n `Branch\n ~id:\"operation.double_inclusion_of_consensus_operation\"\n ~title:\"Double inclusion of consensus operation\"\n ~description:\"double inclusion of consensus operation\"\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"Double inclusion of consensus operation\")\n Data_encoding.empty\n (function\n | Double_inclusion_of_consensus_operation -> Some () | _ -> None)\n (fun () -> Double_inclusion_of_consensus_operation)\n\n let record_grand_parent_endorsement t pkh =\n error_when\n (Signature.Public_key_hash.Set.mem pkh t.grand_parent_endorsements_seen)\n Double_inclusion_of_consensus_operation\n >|? fun () ->\n {\n t with\n grand_parent_endorsements_seen =\n Signature.Public_key_hash.Set.add pkh t.grand_parent_endorsements_seen;\n }\n\n let record_endorsement t ~initial_slot ~power =\n error_when\n (Slot_repr.Set.mem initial_slot t.endorsements_seen)\n Double_inclusion_of_consensus_operation\n >|? fun () ->\n {\n t with\n current_endorsement_power = t.current_endorsement_power + power;\n endorsements_seen = Slot_repr.Set.add initial_slot t.endorsements_seen;\n }\n\n let record_preendorsement ~initial_slot ~power round t =\n error_when\n (Slot_repr.Set.mem initial_slot t.preendorsements_seen)\n Double_inclusion_of_consensus_operation\n >|? fun () ->\n let locked_round_evidence =\n match t.locked_round_evidence with\n | None -> Some (round, power)\n | Some (_stored_round, evidences) ->\n (* In mempool mode, round and stored_round can be different.\n It doesn't matter in that case since quorum certificates\n are not used in mempool.\n For other cases [Apply.check_round] verifies it. *)\n Some (round, evidences + power)\n in\n {\n t with\n locked_round_evidence;\n preendorsements_seen =\n Slot_repr.Set.add initial_slot t.preendorsements_seen;\n }\n\n let set_preendorsements_quorum_round round t =\n match t.preendorsements_quorum_round with\n | Some round' ->\n (* If the rounds are different, an error should have already\n been raised. *)\n assert (Round_repr.equal round round') ;\n t\n | None -> {t with preendorsements_quorum_round = Some round}\n\n let initialize_with_endorsements_and_preendorsements ~allowed_endorsements\n ~allowed_preendorsements t =\n {t with allowed_endorsements; allowed_preendorsements}\n\n let locked_round_evidence t = t.locked_round_evidence\n\n let endorsement_branch t = t.endorsement_branch\n\n let grand_parent_branch t = t.grand_parent_branch\n\n let set_endorsement_branch t endorsement_branch =\n {t with endorsement_branch = Some endorsement_branch}\n\n let set_grand_parent_branch t grand_parent_branch =\n {t with grand_parent_branch = Some grand_parent_branch}\nend\n\ntype dal_committee = {\n pkh_to_shards :\n (Dal_attestation_repr.shard_index * int) Signature.Public_key_hash.Map.t;\n shard_to_pkh : Signature.Public_key_hash.t Dal_attestation_repr.Shard_map.t;\n}\n\nlet empty_dal_committee =\n {\n pkh_to_shards = Signature.Public_key_hash.Map.empty;\n shard_to_pkh = Dal_attestation_repr.Shard_map.empty;\n }\n\ntype back = {\n context : Context.t;\n constants : Constants_parametric_repr.t;\n round_durations : Round_repr.Durations.t;\n cycle_eras : Level_repr.cycle_eras;\n level : Level_repr.t;\n predecessor_timestamp : Time.t;\n timestamp : Time.t;\n fees : Tez_repr.t;\n origination_nonce : Origination_nonce.t option;\n temporary_lazy_storage_ids : Lazy_storage_kind.Temp_ids.t;\n internal_nonce : int;\n internal_nonces_used : Int_set.t;\n remaining_block_gas : Gas_limit_repr.Arith.fp;\n unlimited_operation_gas : bool;\n consensus : Raw_consensus.t;\n non_consensus_operations_rev : Operation_hash.t list;\n dictator_proposal_seen : bool;\n sampler_state : (Seed_repr.seed * consensus_pk Sampler.t) Cycle_repr.Map.t;\n stake_distribution_for_current_cycle :\n Tez_repr.t Signature.Public_key_hash.Map.t option;\n tx_rollup_current_messages :\n Tx_rollup_inbox_repr.Merkle.tree Tx_rollup_repr.Map.t;\n sc_rollup_current_messages : Sc_rollup_inbox_merkelized_payload_hashes_repr.t;\n dal_slot_fee_market : Dal_slot_repr.Slot_market.t;\n (* DAL/FIXME https://gitlab.com/tezos/tezos/-/issues/3105\n\n We associate to a slot header some fees. This enable the use\n of a fee market for slot publication. However, this is not\n resilient from the game theory point of view. Probably we can find\n better incentives here. In any case, because we want the following\n invariant:\n\n - For each level and for each slot there is at most one slot\n header.\n\n - We need to provide an incentive to avoid byzantines to post\n dummy slot headers. *)\n dal_attestation_slot_accountability : Dal_attestation_repr.Accountability.t;\n dal_committee : dal_committee;\n}\n\n(*\n\n The context is simply a record with two fields which\n limits the cost of updating the [remaining_operation_gas].\n\n*)\ntype t = {remaining_operation_gas : Gas_limit_repr.Arith.fp; back : back}\n\ntype root = t\n\n(*\n\n Context fields accessors\n ========================\n\n To have the context related code more robust to evolutions,\n we introduce accessors to get and to update the context\n components.\n\n*)\nlet[@inline] context ctxt = ctxt.back.context\n\nlet[@inline] current_level ctxt = ctxt.back.level\n\nlet[@inline] predecessor_timestamp ctxt = ctxt.back.predecessor_timestamp\n\nlet[@inline] current_timestamp ctxt = ctxt.back.timestamp\n\nlet[@inline] round_durations ctxt = ctxt.back.round_durations\n\nlet[@inline] cycle_eras ctxt = ctxt.back.cycle_eras\n\nlet[@inline] constants ctxt = ctxt.back.constants\n\nlet[@inline] tx_rollup ctxt = ctxt.back.constants.tx_rollup\n\nlet[@inline] sc_rollup ctxt = ctxt.back.constants.sc_rollup\n\nlet[@inline] zk_rollup ctxt = ctxt.back.constants.zk_rollup\n\nlet[@inline] recover ctxt = ctxt.back.context\n\nlet[@inline] fees ctxt = ctxt.back.fees\n\nlet[@inline] origination_nonce ctxt = ctxt.back.origination_nonce\n\nlet[@inline] internal_nonce ctxt = ctxt.back.internal_nonce\n\nlet[@inline] internal_nonces_used ctxt = ctxt.back.internal_nonces_used\n\nlet[@inline] remaining_block_gas ctxt = ctxt.back.remaining_block_gas\n\nlet[@inline] unlimited_operation_gas ctxt = ctxt.back.unlimited_operation_gas\n\nlet[@inline] temporary_lazy_storage_ids ctxt =\n ctxt.back.temporary_lazy_storage_ids\n\nlet[@inline] remaining_operation_gas ctxt = ctxt.remaining_operation_gas\n\nlet[@inline] non_consensus_operations_rev ctxt =\n ctxt.back.non_consensus_operations_rev\n\nlet[@inline] dictator_proposal_seen ctxt = ctxt.back.dictator_proposal_seen\n\nlet[@inline] sampler_state ctxt = ctxt.back.sampler_state\n\nlet[@inline] update_back ctxt back = {ctxt with back}\n\nlet[@inline] update_remaining_block_gas ctxt remaining_block_gas =\n update_back ctxt {ctxt.back with remaining_block_gas}\n\nlet[@inline] update_remaining_operation_gas ctxt remaining_operation_gas =\n {ctxt with remaining_operation_gas}\n\nlet[@inline] update_unlimited_operation_gas ctxt unlimited_operation_gas =\n update_back ctxt {ctxt.back with unlimited_operation_gas}\n\nlet[@inline] update_context ctxt context =\n update_back ctxt {ctxt.back with context}\n\nlet[@inline] update_constants ctxt constants =\n update_back ctxt {ctxt.back with constants}\n\nlet[@inline] update_origination_nonce ctxt origination_nonce =\n update_back ctxt {ctxt.back with origination_nonce}\n\nlet[@inline] update_internal_nonce ctxt internal_nonce =\n update_back ctxt {ctxt.back with internal_nonce}\n\nlet[@inline] update_internal_nonces_used ctxt internal_nonces_used =\n update_back ctxt {ctxt.back with internal_nonces_used}\n\nlet[@inline] update_fees ctxt fees = update_back ctxt {ctxt.back with fees}\n\nlet[@inline] update_temporary_lazy_storage_ids ctxt temporary_lazy_storage_ids =\n update_back ctxt {ctxt.back with temporary_lazy_storage_ids}\n\nlet[@inline] update_non_consensus_operations_rev ctxt\n non_consensus_operations_rev =\n update_back ctxt {ctxt.back with non_consensus_operations_rev}\n\nlet[@inline] update_dictator_proposal_seen ctxt dictator_proposal_seen =\n update_back ctxt {ctxt.back with dictator_proposal_seen}\n\nlet[@inline] update_sampler_state ctxt sampler_state =\n update_back ctxt {ctxt.back with sampler_state}\n\ntype error += Too_many_internal_operations (* `Permanent *)\n\ntype error += Block_quota_exceeded (* `Temporary *)\n\ntype error += Operation_quota_exceeded (* `Temporary *)\n\ntype error += Stake_distribution_not_set (* `Branch *)\n\ntype error += Sampler_already_set of Cycle_repr.t (* `Permanent *)\n\nlet () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"too_many_internal_operations\"\n ~title:\"Too many internal operations\"\n ~description:\n \"A transaction exceeded the hard limit of internal operations it can emit\"\n empty\n (function Too_many_internal_operations -> Some () | _ -> None)\n (fun () -> Too_many_internal_operations) ;\n register_error_kind\n `Temporary\n ~id:\"gas_exhausted.operation\"\n ~title:\"Gas quota exceeded for the operation\"\n ~description:\n \"A script or one of its callee took more time than the operation said it \\\n would\"\n empty\n (function Operation_quota_exceeded -> Some () | _ -> None)\n (fun () -> Operation_quota_exceeded) ;\n register_error_kind\n `Temporary\n ~id:\"gas_exhausted.block\"\n ~title:\"Gas quota exceeded for the block\"\n ~description:\n \"The sum of gas consumed by all the operations in the block exceeds the \\\n hard gas limit per block\"\n empty\n (function Block_quota_exceeded -> Some () | _ -> None)\n (fun () -> Block_quota_exceeded) ;\n register_error_kind\n `Permanent\n ~id:\"delegate.stake_distribution_not_set\"\n ~title:\"Stake distribution not set\"\n ~description:\"The stake distribution for the current cycle is not set.\"\n ~pp:(fun ppf () ->\n Format.fprintf\n ppf\n \"The stake distribution for the current cycle is not set.\")\n empty\n (function Stake_distribution_not_set -> Some () | _ -> None)\n (fun () -> Stake_distribution_not_set) ;\n register_error_kind\n `Permanent\n ~id:\"sampler_already_set\"\n ~title:\"Sampler already set\"\n ~description:\n \"Internal error: Raw_context.set_sampler_for_cycle was called twice for \\\n a given cycle\"\n ~pp:(fun ppf c ->\n Format.fprintf\n ppf\n \"Internal error: sampler already set for cycle %a.\"\n Cycle_repr.pp\n c)\n (obj1 (req \"cycle\" Cycle_repr.encoding))\n (function Sampler_already_set c -> Some c | _ -> None)\n (fun c -> Sampler_already_set c)\n\nlet fresh_internal_nonce ctxt =\n if Compare.Int.(internal_nonce ctxt >= 65_535) then\n error Too_many_internal_operations\n else\n ok\n (update_internal_nonce ctxt (internal_nonce ctxt + 1), internal_nonce ctxt)\n\nlet reset_internal_nonce ctxt =\n let ctxt = update_internal_nonce ctxt 0 in\n update_internal_nonces_used ctxt Int_set.empty\n\nlet record_internal_nonce ctxt k =\n update_internal_nonces_used ctxt (Int_set.add k (internal_nonces_used ctxt))\n\nlet internal_nonce_already_recorded ctxt k =\n Int_set.mem k (internal_nonces_used ctxt)\n\nlet get_collected_fees ctxt = fees ctxt\n\nlet credit_collected_fees_only_call_from_token ctxt fees' =\n let previous = get_collected_fees ctxt in\n Tez_repr.(previous +? fees') >|? fun fees -> update_fees ctxt fees\n\nlet spend_collected_fees_only_call_from_token ctxt fees' =\n let previous = get_collected_fees ctxt in\n Tez_repr.(previous -? fees') >|? fun fees -> update_fees ctxt fees\n\ntype error += Undefined_operation_nonce (* `Permanent *)\n\nlet () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"undefined_operation_nonce\"\n ~title:\"Ill timed access to the origination nonce\"\n ~description:\n \"An origination was attempted out of the scope of a manager operation\"\n empty\n (function Undefined_operation_nonce -> Some () | _ -> None)\n (fun () -> Undefined_operation_nonce)\n\nlet init_origination_nonce ctxt operation_hash =\n let origination_nonce = Some (Origination_nonce.initial operation_hash) in\n update_origination_nonce ctxt origination_nonce\n\nlet increment_origination_nonce ctxt =\n match origination_nonce ctxt with\n | None -> error Undefined_operation_nonce\n | Some cur_origination_nonce ->\n let origination_nonce =\n Some (Origination_nonce.incr cur_origination_nonce)\n in\n let ctxt = update_origination_nonce ctxt origination_nonce in\n ok (ctxt, cur_origination_nonce)\n\nlet get_origination_nonce ctxt =\n match origination_nonce ctxt with\n | None -> error Undefined_operation_nonce\n | Some origination_nonce -> ok origination_nonce\n\nlet unset_origination_nonce ctxt = update_origination_nonce ctxt None\n\nlet gas_level ctxt =\n let open Gas_limit_repr in\n if unlimited_operation_gas ctxt then Unaccounted\n else Limited {remaining = remaining_operation_gas ctxt}\n\nlet block_gas_level = remaining_block_gas\n\nlet consume_gas_limit_in_block ctxt gas_limit =\n let open Gas_limit_repr in\n check_gas_limit\n ~hard_gas_limit_per_operation:(constants ctxt).hard_gas_limit_per_operation\n ~gas_limit\n >>? fun () ->\n let block_gas = block_gas_level ctxt in\n let limit = Arith.fp gas_limit in\n if Arith.(limit > block_gas) then error Block_quota_exceeded\n else\n let level = Arith.sub (block_gas_level ctxt) limit in\n let ctxt = update_remaining_block_gas ctxt level in\n Ok ctxt\n\nlet set_gas_limit ctxt (remaining : 'a Gas_limit_repr.Arith.t) =\n let open Gas_limit_repr in\n let remaining_operation_gas = Arith.fp remaining in\n let ctxt = update_unlimited_operation_gas ctxt false in\n {ctxt with remaining_operation_gas}\n\nlet set_gas_unlimited ctxt = update_unlimited_operation_gas ctxt true\n\nlet consume_gas ctxt cost =\n match Gas_limit_repr.raw_consume (remaining_operation_gas ctxt) cost with\n | Some gas_counter -> Ok (update_remaining_operation_gas ctxt gas_counter)\n | None ->\n if unlimited_operation_gas ctxt then ok ctxt\n else error Operation_quota_exceeded\n\nlet check_enough_gas ctxt cost =\n consume_gas ctxt cost >>? fun (_ : t) -> Result.return_unit\n\nlet gas_consumed ~since ~until =\n match (gas_level since, gas_level until) with\n | Limited {remaining = before}, Limited {remaining = after} ->\n Gas_limit_repr.Arith.sub before after\n | _, _ -> Gas_limit_repr.Arith.zero\n\ntype missing_key_kind = Get | Set | Del | Copy\n\ntype storage_error =\n | Incompatible_protocol_version of string\n | Missing_key of string list * missing_key_kind\n | Existing_key of string list\n | Corrupted_data of string list\n\nlet storage_error_encoding =\n let open Data_encoding in\n union\n [\n case\n (Tag 0)\n ~title:\"Incompatible_protocol_version\"\n (obj1 (req \"incompatible_protocol_version\" @@ string Plain))\n (function Incompatible_protocol_version arg -> Some arg | _ -> None)\n (fun arg -> Incompatible_protocol_version arg);\n case\n (Tag 1)\n ~title:\"Missing_key\"\n (obj2\n (req \"missing_key\" (list @@ string Plain))\n (req\n \"function\"\n (string_enum\n [(\"get\", Get); (\"set\", Set); (\"del\", Del); (\"copy\", Copy)])))\n (function Missing_key (key, f) -> Some (key, f) | _ -> None)\n (fun (key, f) -> Missing_key (key, f));\n case\n (Tag 2)\n ~title:\"Existing_key\"\n (obj1 (req \"existing_key\" (list @@ string Plain)))\n (function Existing_key key -> Some key | _ -> None)\n (fun key -> Existing_key key);\n case\n (Tag 3)\n ~title:\"Corrupted_data\"\n (obj1 (req \"corrupted_data\" (list @@ string Plain)))\n (function Corrupted_data key -> Some key | _ -> None)\n (fun key -> Corrupted_data key);\n ]\n\nlet pp_storage_error ppf = function\n | Incompatible_protocol_version version ->\n Format.fprintf\n ppf\n \"Found a context with an unexpected version '%s'.\"\n version\n | Missing_key (key, Get) ->\n Format.fprintf ppf \"Missing key '%s'.\" (String.concat \"/\" key)\n | Missing_key (key, Set) ->\n Format.fprintf\n ppf\n \"Cannot set undefined key '%s'.\"\n (String.concat \"/\" key)\n | Missing_key (key, Del) ->\n Format.fprintf\n ppf\n \"Cannot delete undefined key '%s'.\"\n (String.concat \"/\" key)\n | Missing_key (key, Copy) ->\n Format.fprintf\n ppf\n \"Cannot copy undefined key '%s'.\"\n (String.concat \"/\" key)\n | Existing_key key ->\n Format.fprintf\n ppf\n \"Cannot initialize defined key '%s'.\"\n (String.concat \"/\" key)\n | Corrupted_data key ->\n Format.fprintf\n ppf\n \"Failed to parse the data at '%s'.\"\n (String.concat \"/\" key)\n\ntype error += Storage_error of storage_error\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"context.storage_error\"\n ~title:\"Storage error (fatal internal error)\"\n ~description:\n \"An error that should never happen unless something has been deleted or \\\n corrupted in the database.\"\n ~pp:(fun ppf err ->\n Format.fprintf ppf \"@[<v 2>Storage error:@ %a@]\" pp_storage_error err)\n storage_error_encoding\n (function Storage_error err -> Some err | _ -> None)\n (fun err -> Storage_error err)\n\nlet storage_error err = error (Storage_error err)\n\n(* Initialization *********************************************************)\n\n(* This key should always be populated for every version of the\n protocol. It's absence meaning that the context is empty. *)\nlet version_key = [\"version\"]\n\n(* This value is set by the snapshot_alpha.sh script, don't change it. *)\nlet version_value = \"mumbai_016\"\n\nlet version = \"v1\"\n\nlet cycle_eras_key = [version; \"cycle_eras\"]\n\nlet constants_key = [version; \"constants\"]\n\nlet protocol_param_key = [\"protocol_parameters\"]\n\nlet get_cycle_eras ctxt =\n Context.find ctxt cycle_eras_key >|= function\n | None -> storage_error (Missing_key (cycle_eras_key, Get))\n | Some bytes -> (\n match\n Data_encoding.Binary.of_bytes_opt Level_repr.cycle_eras_encoding bytes\n with\n | None -> storage_error (Corrupted_data cycle_eras_key)\n | Some cycle_eras -> ok cycle_eras)\n\nlet set_cycle_eras ctxt cycle_eras =\n let bytes =\n Data_encoding.Binary.to_bytes_exn Level_repr.cycle_eras_encoding cycle_eras\n in\n Context.add ctxt cycle_eras_key bytes >|= ok\n\ntype error += Failed_to_parse_parameter of bytes\n\ntype error += Failed_to_decode_parameter of Data_encoding.json * string\n\nlet () =\n register_error_kind\n `Temporary\n ~id:\"context.failed_to_parse_parameter\"\n ~title:\"Failed to parse parameter\"\n ~description:\"The protocol parameters are not valid JSON.\"\n ~pp:(fun ppf bytes ->\n Format.fprintf\n ppf\n \"@[<v 2>Cannot parse the protocol parameter:@ %s@]\"\n (Bytes.to_string bytes))\n Data_encoding.(obj1 (req \"contents\" @@ bytes Hex))\n (function Failed_to_parse_parameter data -> Some data | _ -> None)\n (fun data -> Failed_to_parse_parameter data) ;\n register_error_kind\n `Temporary\n ~id:\"context.failed_to_decode_parameter\"\n ~title:\"Failed to decode parameter\"\n ~description:\"Unexpected JSON object.\"\n ~pp:(fun ppf (json, msg) ->\n Format.fprintf\n ppf\n \"@[<v 2>Cannot decode the protocol parameter:@ %s@ %a@]\"\n msg\n Data_encoding.Json.pp\n json)\n Data_encoding.(obj2 (req \"contents\" json) (req \"error\" @@ string Plain))\n (function\n | Failed_to_decode_parameter (json, msg) -> Some (json, msg) | _ -> None)\n (fun (json, msg) -> Failed_to_decode_parameter (json, msg))\n\nlet get_proto_param ctxt =\n Context.find ctxt protocol_param_key >>= function\n | None -> failwith \"Missing protocol parameters.\"\n | Some bytes -> (\n match Data_encoding.Binary.of_bytes_opt Data_encoding.json bytes with\n | None -> tzfail (Failed_to_parse_parameter bytes)\n | Some json -> (\n Context.remove ctxt protocol_param_key >|= fun ctxt ->\n match Data_encoding.Json.destruct Parameters_repr.encoding json with\n | exception (Data_encoding.Json.Cannot_destruct _ as exn) ->\n Format.kasprintf\n failwith\n \"Invalid protocol_parameters: %a %a\"\n (fun ppf -> Data_encoding.Json.print_error ppf)\n exn\n Data_encoding.Json.pp\n json\n | param ->\n Parameters_repr.check_params param >>? fun () -> ok (param, ctxt))\n )\n\nlet add_constants ctxt constants =\n let bytes =\n Data_encoding.Binary.to_bytes_exn\n Constants_parametric_repr.encoding\n constants\n in\n Context.add ctxt constants_key bytes\n\nlet get_constants ctxt =\n Context.find ctxt constants_key >|= function\n | None -> failwith \"Internal error: cannot read constants in context.\"\n | Some bytes -> (\n match\n Data_encoding.Binary.of_bytes_opt\n Constants_parametric_repr.encoding\n bytes\n with\n | None -> failwith \"Internal error: cannot parse constants in context.\"\n | Some constants -> ok constants)\n\nlet patch_constants ctxt f =\n let constants = f (constants ctxt) in\n add_constants (context ctxt) constants >|= fun context ->\n let ctxt = update_context ctxt context in\n update_constants ctxt constants\n\nlet check_inited ctxt =\n Context.find ctxt version_key >|= function\n | None -> failwith \"Internal error: un-initialized context.\"\n | Some bytes ->\n let s = Bytes.to_string bytes in\n if Compare.String.(s = version_value) then Result.return_unit\n else storage_error (Incompatible_protocol_version s)\n\nlet check_cycle_eras (cycle_eras : Level_repr.cycle_eras)\n (constants : Constants_parametric_repr.t) =\n let current_era = Level_repr.current_era cycle_eras in\n assert (\n Compare.Int32.(current_era.blocks_per_cycle = constants.blocks_per_cycle)) ;\n assert (\n Compare.Int32.(\n current_era.blocks_per_commitment = constants.blocks_per_commitment))\n\nlet prepare ~level ~predecessor_timestamp ~timestamp ctxt =\n Raw_level_repr.of_int32 level >>?= fun level ->\n check_inited ctxt >>=? fun () ->\n get_constants ctxt >>=? fun constants ->\n Round_repr.Durations.create\n ~first_round_duration:constants.minimal_block_delay\n ~delay_increment_per_round:constants.delay_increment_per_round\n >>?= fun round_durations ->\n get_cycle_eras ctxt >|=? fun cycle_eras ->\n check_cycle_eras cycle_eras constants ;\n let level = Level_repr.level_from_raw ~cycle_eras level in\n let sc_rollup_current_messages =\n Sc_rollup_inbox_repr.init_witness_no_history\n in\n {\n remaining_operation_gas = Gas_limit_repr.Arith.zero;\n back =\n {\n context = ctxt;\n constants;\n level;\n predecessor_timestamp;\n timestamp;\n round_durations;\n cycle_eras;\n fees = Tez_repr.zero;\n origination_nonce = None;\n temporary_lazy_storage_ids = Lazy_storage_kind.Temp_ids.init;\n internal_nonce = 0;\n internal_nonces_used = Int_set.empty;\n remaining_block_gas =\n Gas_limit_repr.Arith.fp\n constants.Constants_parametric_repr.hard_gas_limit_per_block;\n unlimited_operation_gas = true;\n consensus = Raw_consensus.empty;\n non_consensus_operations_rev = [];\n dictator_proposal_seen = false;\n sampler_state = Cycle_repr.Map.empty;\n stake_distribution_for_current_cycle = None;\n tx_rollup_current_messages = Tx_rollup_repr.Map.empty;\n sc_rollup_current_messages;\n dal_slot_fee_market =\n Dal_slot_repr.Slot_market.init\n ~length:constants.Constants_parametric_repr.dal.number_of_slots;\n dal_attestation_slot_accountability =\n Dal_attestation_repr.Accountability.init\n ~length:constants.Constants_parametric_repr.dal.number_of_slots;\n dal_committee = empty_dal_committee;\n };\n }\n\ntype previous_protocol = Genesis of Parameters_repr.t | Lima_015\n\nlet check_and_update_protocol_version ctxt =\n (Context.find ctxt version_key >>= function\n | None ->\n failwith \"Internal error: un-initialized context in check_first_block.\"\n | Some bytes ->\n let s = Bytes.to_string bytes in\n if Compare.String.(s = version_value) then\n failwith \"Internal error: previously initialized context.\"\n else if Compare.String.(s = \"genesis\") then\n get_proto_param ctxt >|=? fun (param, ctxt) -> (Genesis param, ctxt)\n else if Compare.String.(s = \"lima_015\") then return (Lima_015, ctxt)\n else Lwt.return @@ storage_error (Incompatible_protocol_version s))\n >>=? fun (previous_proto, ctxt) ->\n Context.add ctxt version_key (Bytes.of_string version_value) >|= fun ctxt ->\n ok (previous_proto, ctxt)\n\n(* only for the migration *)\nlet[@warning \"-32\"] get_previous_protocol_constants ctxt =\n Context.find ctxt constants_key >>= function\n | None ->\n failwith\n \"Internal error: cannot read previous protocol constants in context.\"\n | Some bytes -> (\n match\n Data_encoding.Binary.of_bytes_opt\n Constants_parametric_previous_repr.encoding\n bytes\n with\n | None ->\n failwith\n \"Internal error: cannot parse previous protocol constants in \\\n context.\"\n | Some constants -> Lwt.return constants)\n\nlet update_block_time_related_constants (c : Constants_parametric_repr.t) =\n let divide_period p =\n Period_repr.of_seconds_exn\n Int64.(div (add (Period_repr.to_seconds p) 1L) 2L)\n in\n let minimal_block_delay = divide_period c.minimal_block_delay in\n let delay_increment_per_round = divide_period c.delay_increment_per_round in\n let hard_gas_limit_per_block =\n let two = Z.(succ one) in\n Gas_limit_repr.Arith.(\n integral_exn (Z.div (integral_to_z c.hard_gas_limit_per_block) two))\n in\n let Constants_repr.Generated.\n {\n consensus_threshold = _;\n baking_reward_fixed_portion;\n baking_reward_bonus_per_slot;\n endorsing_reward_per_slot;\n liquidity_baking_subsidy;\n } =\n Constants_repr.Generated.generate\n ~consensus_committee_size:\n c.Constants_parametric_repr.consensus_committee_size\n ~blocks_per_minute:\n {\n numerator = 60;\n denominator =\n minimal_block_delay |> Period_repr.to_seconds |> Int64.to_int;\n }\n in\n let double = Int32.mul 2l in\n let blocks_per_cycle = double c.blocks_per_cycle in\n let blocks_per_commitment = double c.blocks_per_commitment in\n let nonce_revelation_threshold = double c.nonce_revelation_threshold in\n let blocks_per_stake_snapshot = double c.blocks_per_stake_snapshot in\n let max_operations_time_to_live = 2 * c.max_operations_time_to_live in\n {\n c with\n blocks_per_cycle;\n blocks_per_commitment;\n nonce_revelation_threshold;\n blocks_per_stake_snapshot;\n max_operations_time_to_live;\n minimal_block_delay;\n delay_increment_per_round;\n hard_gas_limit_per_block;\n baking_reward_fixed_portion;\n baking_reward_bonus_per_slot;\n endorsing_reward_per_slot;\n liquidity_baking_subsidy;\n }\n\nlet update_cycle_eras ctxt level ~prev_blocks_per_cycle ~blocks_per_cycle\n ~blocks_per_commitment =\n get_cycle_eras ctxt >>=? fun cycle_eras ->\n let current_era = Level_repr.current_era cycle_eras in\n let current_cycle =\n let level_position =\n Int32.sub level (Raw_level_repr.to_int32 current_era.first_level)\n in\n Cycle_repr.add\n current_era.first_cycle\n (Int32.to_int (Int32.div level_position prev_blocks_per_cycle))\n in\n let new_cycle_era =\n Level_repr.\n {\n first_level = Raw_level_repr.of_int32_exn (Int32.succ level);\n first_cycle = Cycle_repr.succ current_cycle;\n blocks_per_cycle;\n blocks_per_commitment;\n }\n in\n Level_repr.add_cycle_era new_cycle_era cycle_eras >>?= fun new_cycle_eras ->\n set_cycle_eras ctxt new_cycle_eras\n\n(* You should ensure that if the type `Constants_parametric_repr.t` is\n different from `Constants_parametric_previous_repr.t` or the value of these\n constants is modified, is changed from the previous protocol, then\n you `propagate` these constants to the new protocol by writing them\n onto the context via the function `add_constants` or\n `patch_constants`.\n\n This migration can be achieved also implicitly by modifying the\n encoding directly in a way which is compatible with the previous\n protocol. However, by doing so, you do not change the value of\n these constants inside the context. *)\nlet prepare_first_block ~level ~timestamp ctxt =\n check_and_update_protocol_version ctxt >>=? fun (previous_proto, ctxt) ->\n (match previous_proto with\n | Genesis param ->\n Raw_level_repr.of_int32 level >>?= fun first_level ->\n let cycle_era =\n {\n Level_repr.first_level;\n first_cycle = Cycle_repr.root;\n blocks_per_cycle = param.constants.blocks_per_cycle;\n blocks_per_commitment = param.constants.blocks_per_commitment;\n }\n in\n Level_repr.create_cycle_eras [cycle_era] >>?= fun cycle_eras ->\n set_cycle_eras ctxt cycle_eras >>=? fun ctxt ->\n add_constants ctxt param.constants >|= ok\n | Lima_015 ->\n get_previous_protocol_constants ctxt >>= fun c ->\n let tx_rollup =\n Constants_parametric_repr.\n {\n enable = false;\n origination_size = c.tx_rollup.origination_size;\n hard_size_limit_per_inbox = c.tx_rollup.hard_size_limit_per_inbox;\n hard_size_limit_per_message =\n c.tx_rollup.hard_size_limit_per_message;\n max_withdrawals_per_batch = c.tx_rollup.max_withdrawals_per_batch;\n max_ticket_payload_size = c.tx_rollup.max_ticket_payload_size;\n commitment_bond = c.tx_rollup.commitment_bond;\n finality_period = c.tx_rollup.finality_period;\n withdraw_period = c.tx_rollup.withdraw_period;\n max_inboxes_count = c.tx_rollup.max_inboxes_count;\n max_messages_per_inbox = c.tx_rollup.max_messages_per_inbox;\n max_commitments_count = c.tx_rollup.max_commitments_count;\n cost_per_byte_ema_factor = c.tx_rollup.cost_per_byte_ema_factor;\n rejection_max_proof_size = c.tx_rollup.rejection_max_proof_size;\n sunset_level = c.tx_rollup.sunset_level;\n }\n in\n let cryptobox_parameters =\n {\n Dal.page_size = 4096;\n number_of_shards = 2048;\n slot_size = 1 lsl 20;\n redundancy_factor = 16;\n }\n in\n let dal =\n Constants_parametric_repr.\n {\n feature_enable = c.dal.feature_enable;\n number_of_slots = c.dal.number_of_slots;\n attestation_lag = c.dal.endorsement_lag;\n availability_threshold = c.dal.availability_threshold;\n cryptobox_parameters;\n }\n in\n let sc_rollup =\n Constants_parametric_repr.\n {\n enable = true;\n arith_pvm_enable = false;\n origination_size = c.sc_rollup.origination_size;\n challenge_window_in_blocks = 80_640;\n stake_amount = c.sc_rollup.stake_amount;\n commitment_period_in_blocks = 60;\n max_lookahead_in_blocks = 172_800l;\n max_active_outbox_levels = 80_640l;\n max_outbox_messages_per_level =\n c.sc_rollup.max_outbox_messages_per_level;\n number_of_sections_in_dissection =\n c.sc_rollup.number_of_sections_in_dissection;\n timeout_period_in_blocks = 40_320;\n max_number_of_stored_cemented_commitments =\n c.sc_rollup.max_number_of_stored_cemented_commitments;\n max_number_of_parallel_games = 32;\n }\n in\n let zk_rollup =\n Constants_parametric_repr.\n {\n enable = c.zk_rollup.enable;\n origination_size = c.zk_rollup.origination_size;\n min_pending_to_process = c.zk_rollup.min_pending_to_process;\n }\n in\n let constants =\n Constants_parametric_repr.\n {\n preserved_cycles = c.preserved_cycles;\n blocks_per_cycle = c.blocks_per_cycle;\n blocks_per_commitment = c.blocks_per_commitment;\n nonce_revelation_threshold = c.nonce_revelation_threshold;\n blocks_per_stake_snapshot = c.blocks_per_stake_snapshot;\n cycles_per_voting_period = c.cycles_per_voting_period;\n hard_gas_limit_per_operation = c.hard_gas_limit_per_operation;\n hard_gas_limit_per_block = c.hard_gas_limit_per_block;\n proof_of_work_threshold = c.proof_of_work_threshold;\n minimal_stake = c.minimal_stake;\n vdf_difficulty = c.vdf_difficulty;\n seed_nonce_revelation_tip = c.seed_nonce_revelation_tip;\n origination_size = c.origination_size;\n max_operations_time_to_live = c.max_operations_time_to_live;\n baking_reward_fixed_portion = c.baking_reward_fixed_portion;\n baking_reward_bonus_per_slot = c.baking_reward_bonus_per_slot;\n endorsing_reward_per_slot = c.endorsing_reward_per_slot;\n cost_per_byte = c.cost_per_byte;\n hard_storage_limit_per_operation =\n c.hard_storage_limit_per_operation;\n quorum_min = c.quorum_min;\n quorum_max = c.quorum_max;\n min_proposal_quorum = c.min_proposal_quorum;\n liquidity_baking_subsidy = c.liquidity_baking_subsidy;\n liquidity_baking_toggle_ema_threshold =\n c.liquidity_baking_toggle_ema_threshold;\n minimal_block_delay = c.minimal_block_delay;\n delay_increment_per_round = c.delay_increment_per_round;\n consensus_committee_size = c.consensus_committee_size;\n consensus_threshold = c.consensus_threshold;\n minimal_participation_ratio = c.minimal_participation_ratio;\n max_slashing_period = c.max_slashing_period;\n frozen_deposits_percentage = c.frozen_deposits_percentage;\n double_baking_punishment = c.double_baking_punishment;\n ratio_of_frozen_deposits_slashed_per_double_endorsement =\n c.ratio_of_frozen_deposits_slashed_per_double_endorsement;\n (* The `testnet_dictator` should absolutely be None on mainnet *)\n testnet_dictator = c.testnet_dictator;\n initial_seed = c.initial_seed;\n cache_script_size = c.cache_script_size;\n cache_stake_distribution_cycles = c.cache_stake_distribution_cycles;\n cache_sampler_state_cycles = c.cache_sampler_state_cycles;\n tx_rollup;\n dal;\n sc_rollup;\n zk_rollup;\n }\n in\n let block_time_is_at_least_15s =\n Compare.Int64.(Period_repr.to_seconds c.minimal_block_delay >= 15L)\n in\n (if block_time_is_at_least_15s then\n let new_constants = update_block_time_related_constants constants in\n update_cycle_eras\n ctxt\n level\n ~prev_blocks_per_cycle:constants.blocks_per_cycle\n ~blocks_per_cycle:new_constants.blocks_per_cycle\n ~blocks_per_commitment:new_constants.blocks_per_commitment\n >>=? fun ctxt -> return (ctxt, new_constants)\n else return (ctxt, constants))\n >>=? fun (ctxt, constants) ->\n add_constants ctxt constants >>= fun ctxt -> return ctxt)\n >>=? fun ctxt ->\n prepare ctxt ~level ~predecessor_timestamp:timestamp ~timestamp\n >|=? fun ctxt -> (previous_proto, ctxt)\n\nlet activate ctxt h = Updater.activate (context ctxt) h >|= update_context ctxt\n\n(* Generic context ********************************************************)\n\ntype key = string list\n\ntype value = bytes\n\ntype tree = Context.tree\n\nmodule type T =\n Raw_context_intf.T\n with type root := root\n and type key := key\n and type value := value\n and type tree := tree\n\nlet mem ctxt k = Context.mem (context ctxt) k\n\nlet mem_tree ctxt k = Context.mem_tree (context ctxt) k\n\nlet get ctxt k =\n Context.find (context ctxt) k >|= function\n | None -> storage_error (Missing_key (k, Get))\n | Some v -> ok v\n\nlet get_tree ctxt k =\n Context.find_tree (context ctxt) k >|= function\n | None -> storage_error (Missing_key (k, Get))\n | Some v -> ok v\n\nlet find ctxt k = Context.find (context ctxt) k\n\nlet find_tree ctxt k = Context.find_tree (context ctxt) k\n\nlet add ctxt k v = Context.add (context ctxt) k v >|= update_context ctxt\n\nlet add_tree ctxt k v =\n Context.add_tree (context ctxt) k v >|= update_context ctxt\n\nlet init ctxt k v =\n Context.mem (context ctxt) k >>= function\n | true -> Lwt.return @@ storage_error (Existing_key k)\n | _ ->\n Context.add (context ctxt) k v >|= fun context ->\n ok (update_context ctxt context)\n\nlet init_tree ctxt k v : _ tzresult Lwt.t =\n Context.mem_tree (context ctxt) k >>= function\n | true -> Lwt.return @@ storage_error (Existing_key k)\n | _ ->\n Context.add_tree (context ctxt) k v >|= fun context ->\n ok (update_context ctxt context)\n\nlet update ctxt k v =\n Context.mem (context ctxt) k >>= function\n | false -> Lwt.return @@ storage_error (Missing_key (k, Set))\n | _ ->\n Context.add (context ctxt) k v >|= fun context ->\n ok (update_context ctxt context)\n\nlet update_tree ctxt k v =\n Context.mem_tree (context ctxt) k >>= function\n | false -> Lwt.return @@ storage_error (Missing_key (k, Set))\n | _ ->\n Context.add_tree (context ctxt) k v >|= fun context ->\n ok (update_context ctxt context)\n\n(* Verify that the key is present before deleting *)\nlet remove_existing ctxt k =\n Context.mem (context ctxt) k >>= function\n | false -> Lwt.return @@ storage_error (Missing_key (k, Del))\n | _ ->\n Context.remove (context ctxt) k >|= fun context ->\n ok (update_context ctxt context)\n\n(* Verify that the key is present before deleting *)\nlet remove_existing_tree ctxt k =\n Context.mem_tree (context ctxt) k >>= function\n | false -> Lwt.return @@ storage_error (Missing_key (k, Del))\n | _ ->\n Context.remove (context ctxt) k >|= fun context ->\n ok (update_context ctxt context)\n\n(* Do not verify before deleting *)\nlet remove ctxt k = Context.remove (context ctxt) k >|= update_context ctxt\n\nlet add_or_remove ctxt k = function\n | None -> remove ctxt k\n | Some v -> add ctxt k v\n\nlet add_or_remove_tree ctxt k = function\n | None -> remove ctxt k\n | Some v -> add_tree ctxt k v\n\nlet list ctxt ?offset ?length k = Context.list (context ctxt) ?offset ?length k\n\nlet fold ?depth ctxt k ~order ~init ~f =\n Context.fold ?depth (context ctxt) k ~order ~init ~f\n\nlet config ctxt = Context.config (context ctxt)\n\nmodule Proof = Context.Proof\n\nlet length ctxt key = Context.length (context ctxt) key\n\nmodule Tree :\n Raw_context_intf.TREE\n with type t := t\n and type key := key\n and type value := value\n and type tree := tree = struct\n include Context.Tree\n\n let empty ctxt = Context.Tree.empty (context ctxt)\n\n let get t k =\n find t k >|= function\n | None -> storage_error (Missing_key (k, Get))\n | Some v -> ok v\n\n let get_tree t k =\n find_tree t k >|= function\n | None -> storage_error (Missing_key (k, Get))\n | Some v -> ok v\n\n let init t k v =\n mem t k >>= function\n | true -> Lwt.return @@ storage_error (Existing_key k)\n | _ -> add t k v >|= ok\n\n let init_tree t k v =\n mem_tree t k >>= function\n | true -> Lwt.return @@ storage_error (Existing_key k)\n | _ -> add_tree t k v >|= ok\n\n let update t k v =\n mem t k >>= function\n | false -> Lwt.return @@ storage_error (Missing_key (k, Set))\n | _ -> add t k v >|= ok\n\n let update_tree t k v =\n mem_tree t k >>= function\n | false -> Lwt.return @@ storage_error (Missing_key (k, Set))\n | _ -> add_tree t k v >|= ok\n\n (* Verify that the key is present before deleting *)\n let remove_existing t k =\n mem t k >>= function\n | false -> Lwt.return @@ storage_error (Missing_key (k, Del))\n | _ -> remove t k >|= ok\n\n (* Verify that the key is present before deleting *)\n let remove_existing_tree t k =\n mem_tree t k >>= function\n | false -> Lwt.return @@ storage_error (Missing_key (k, Del))\n | _ -> remove t k >|= ok\n\n let add_or_remove t k = function None -> remove t k | Some v -> add t k v\n\n let add_or_remove_tree t k = function\n | None -> remove t k\n | Some v -> add_tree t k v\nend\n\nlet verify_tree_proof proof f = Context.verify_tree_proof proof f\n\nlet verify_stream_proof proof f = Context.verify_stream_proof proof f\n\nlet equal_config = Context.equal_config\n\nlet project x = x\n\nlet absolute_key _ k = k\n\nlet description = Storage_description.create ()\n\nlet fold_map_temporary_lazy_storage_ids ctxt f =\n f (temporary_lazy_storage_ids ctxt) |> fun (temporary_lazy_storage_ids, x) ->\n (update_temporary_lazy_storage_ids ctxt temporary_lazy_storage_ids, x)\n\nlet map_temporary_lazy_storage_ids_s ctxt f =\n f (temporary_lazy_storage_ids ctxt)\n >|= fun (ctxt, temporary_lazy_storage_ids) ->\n update_temporary_lazy_storage_ids ctxt temporary_lazy_storage_ids\n\nmodule Cache = struct\n type key = Context.Cache.key\n\n type value = Context.Cache.value = ..\n\n let key_of_identifier = Context.Cache.key_of_identifier\n\n let identifier_of_key = Context.Cache.identifier_of_key\n\n let pp fmt ctxt = Context.Cache.pp fmt (context ctxt)\n\n let find c k = Context.Cache.find (context c) k\n\n let set_cache_layout c layout =\n Context.Cache.set_cache_layout (context c) layout >>= fun ctxt ->\n Lwt.return (update_context c ctxt)\n\n let update c k v = Context.Cache.update (context c) k v |> update_context c\n\n let sync c cache_nonce =\n Context.Cache.sync (context c) ~cache_nonce >>= fun ctxt ->\n Lwt.return (update_context c ctxt)\n\n let clear c = Context.Cache.clear (context c) |> update_context c\n\n let list_keys c ~cache_index =\n Context.Cache.list_keys (context c) ~cache_index\n\n let key_rank c key = Context.Cache.key_rank (context c) key\n\n let cache_size_limit c ~cache_index =\n Context.Cache.cache_size_limit (context c) ~cache_index\n\n let cache_size c ~cache_index =\n Context.Cache.cache_size (context c) ~cache_index\n\n let future_cache_expectation c ~time_in_blocks =\n Context.Cache.future_cache_expectation (context c) ~time_in_blocks\n |> update_context c\nend\n\nlet record_non_consensus_operation_hash ctxt operation_hash =\n update_non_consensus_operations_rev\n ctxt\n (operation_hash :: non_consensus_operations_rev ctxt)\n\nlet non_consensus_operations ctxt = List.rev (non_consensus_operations_rev ctxt)\n\nlet record_dictator_proposal_seen ctxt = update_dictator_proposal_seen ctxt true\n\nlet dictator_proposal_seen ctxt = dictator_proposal_seen ctxt\n\nlet init_sampler_for_cycle ctxt cycle seed state =\n let map = sampler_state ctxt in\n if Cycle_repr.Map.mem cycle map then error (Sampler_already_set cycle)\n else\n let map = Cycle_repr.Map.add cycle (seed, state) map in\n let ctxt = update_sampler_state ctxt map in\n ok ctxt\n\nlet sampler_for_cycle ~read ctxt cycle =\n let map = sampler_state ctxt in\n match Cycle_repr.Map.find cycle map with\n | Some (seed, state) -> return (ctxt, seed, state)\n | None ->\n read ctxt >>=? fun (seed, state) ->\n let map = Cycle_repr.Map.add cycle (seed, state) map in\n let ctxt = update_sampler_state ctxt map in\n return (ctxt, seed, state)\n\nlet stake_distribution_for_current_cycle ctxt =\n match ctxt.back.stake_distribution_for_current_cycle with\n | None -> error Stake_distribution_not_set\n | Some s -> ok s\n\nlet init_stake_distribution_for_current_cycle ctxt\n stake_distribution_for_current_cycle =\n update_back\n ctxt\n {\n ctxt.back with\n stake_distribution_for_current_cycle =\n Some stake_distribution_for_current_cycle;\n }\n\nmodule Internal_for_tests = struct\n let add_level ctxt l =\n let new_level = Level_repr.Internal_for_tests.add_level ctxt.back.level l in\n let new_back = {ctxt.back with level = new_level} in\n {ctxt with back = new_back}\n\n let add_cycles ctxt l =\n let blocks_per_cycle = Int32.to_int (constants ctxt).blocks_per_cycle in\n let new_level =\n Level_repr.Internal_for_tests.add_cycles\n ~blocks_per_cycle\n ctxt.back.level\n l\n in\n let new_back = {ctxt.back with level = new_level} in\n {ctxt with back = new_back}\nend\n\nmodule type CONSENSUS = sig\n type t\n\n type 'value slot_map\n\n type slot_set\n\n type slot\n\n type round\n\n type consensus_pk\n\n val allowed_endorsements : t -> (consensus_pk * int) slot_map\n\n val allowed_preendorsements : t -> (consensus_pk * int) slot_map\n\n val current_endorsement_power : t -> int\n\n val initialize_consensus_operation :\n t ->\n allowed_endorsements:(consensus_pk * int) slot_map ->\n allowed_preendorsements:(consensus_pk * int) slot_map ->\n t\n\n val record_grand_parent_endorsement :\n t -> Signature.Public_key_hash.t -> t tzresult\n\n val record_endorsement : t -> initial_slot:slot -> power:int -> t tzresult\n\n val record_preendorsement :\n t -> initial_slot:slot -> power:int -> round -> t tzresult\n\n val endorsements_seen : t -> slot_set\n\n val get_preendorsements_quorum_round : t -> round option\n\n val set_preendorsements_quorum_round : t -> round -> t\n\n val locked_round_evidence : t -> (round * int) option\n\n val set_endorsement_branch : t -> Block_hash.t * Block_payload_hash.t -> t\n\n val endorsement_branch : t -> (Block_hash.t * Block_payload_hash.t) option\n\n val set_grand_parent_branch : t -> Block_hash.t * Block_payload_hash.t -> t\n\n val grand_parent_branch : t -> (Block_hash.t * Block_payload_hash.t) option\nend\n\nmodule Consensus :\n CONSENSUS\n with type t := t\n and type slot := Slot_repr.t\n and type 'a slot_map := 'a Slot_repr.Map.t\n and type slot_set := Slot_repr.Set.t\n and type round := Round_repr.t\n and type consensus_pk := consensus_pk = struct\n let[@inline] allowed_endorsements ctxt =\n ctxt.back.consensus.allowed_endorsements\n\n let[@inline] allowed_preendorsements ctxt =\n ctxt.back.consensus.allowed_preendorsements\n\n let[@inline] current_endorsement_power ctxt =\n ctxt.back.consensus.current_endorsement_power\n\n let[@inline] get_preendorsements_quorum_round ctxt =\n ctxt.back.consensus.preendorsements_quorum_round\n\n let[@inline] locked_round_evidence ctxt =\n Raw_consensus.locked_round_evidence ctxt.back.consensus\n\n let[@inline] update_consensus_with ctxt f =\n {ctxt with back = {ctxt.back with consensus = f ctxt.back.consensus}}\n\n let[@inline] update_consensus_with_tzresult ctxt f =\n f ctxt.back.consensus >|? fun consensus ->\n {ctxt with back = {ctxt.back with consensus}}\n\n let[@inline] initialize_consensus_operation ctxt ~allowed_endorsements\n ~allowed_preendorsements =\n update_consensus_with\n ctxt\n (Raw_consensus.initialize_with_endorsements_and_preendorsements\n ~allowed_endorsements\n ~allowed_preendorsements)\n\n let[@inline] record_grand_parent_endorsement ctxt pkh =\n update_consensus_with_tzresult ctxt (fun ctxt ->\n Raw_consensus.record_grand_parent_endorsement ctxt pkh)\n\n let[@inline] record_preendorsement ctxt ~initial_slot ~power round =\n update_consensus_with_tzresult\n ctxt\n (Raw_consensus.record_preendorsement ~initial_slot ~power round)\n\n let[@inline] record_endorsement ctxt ~initial_slot ~power =\n update_consensus_with_tzresult\n ctxt\n (Raw_consensus.record_endorsement ~initial_slot ~power)\n\n let[@inline] endorsements_seen ctxt = ctxt.back.consensus.endorsements_seen\n\n let[@inline] set_preendorsements_quorum_round ctxt round =\n update_consensus_with\n ctxt\n (Raw_consensus.set_preendorsements_quorum_round round)\n\n let[@inline] endorsement_branch ctxt =\n Raw_consensus.endorsement_branch ctxt.back.consensus\n\n let[@inline] set_endorsement_branch ctxt branch =\n update_consensus_with ctxt (fun ctxt ->\n Raw_consensus.set_endorsement_branch ctxt branch)\n\n let[@inline] grand_parent_branch ctxt =\n Raw_consensus.grand_parent_branch ctxt.back.consensus\n\n let[@inline] set_grand_parent_branch ctxt branch =\n update_consensus_with ctxt (fun ctxt ->\n Raw_consensus.set_grand_parent_branch ctxt branch)\nend\n\nmodule Tx_rollup = struct\n let add_message ctxt rollup message =\n let root = ref Tx_rollup_inbox_repr.Merkle.(root empty) in\n let updater element =\n let tree =\n Option.value element ~default:Tx_rollup_inbox_repr.Merkle.(empty)\n in\n let tree = Tx_rollup_inbox_repr.Merkle.add_message tree message in\n root := Tx_rollup_inbox_repr.Merkle.root tree ;\n Some tree\n in\n let map =\n Tx_rollup_repr.Map.update\n rollup\n updater\n ctxt.back.tx_rollup_current_messages\n in\n let back = {ctxt.back with tx_rollup_current_messages = map} in\n ({ctxt with back}, !root)\nend\n\n(*\n To optimize message insertion in smart contract rollup inboxes, we\n maintain the sequence of current messages of each rollup used in\n the block in a in-memory map.\n*)\nmodule Sc_rollup_in_memory_inbox = struct\n let current_messages ctxt = ctxt.back.sc_rollup_current_messages\n\n let set_current_messages ctxt witness =\n {ctxt with back = {ctxt.back with sc_rollup_current_messages = witness}}\nend\n\nmodule Dal = struct\n type error +=\n | Dal_register_invalid_slot_header of {\n length : int;\n slot_header : Dal_slot_repr.Header.t;\n }\n\n let () =\n register_error_kind\n `Permanent\n ~id:\"dal_register_invalid_slot\"\n ~title:\"Dal register invalid slot\"\n ~description:\n \"Attempt to register a slot which is invalid (the index is out of \\\n bounds).\"\n ~pp:(fun ppf (length, slot) ->\n Format.fprintf\n ppf\n \"The slot provided is invalid. Slot index should be between 0 and \\\n %d. Found: %a.\"\n length\n Dal_slot_repr.Index.pp\n slot.Dal_slot_repr.Header.id.index)\n Data_encoding.(\n obj2\n (req \"length\" int31)\n (req \"slot_header\" Dal_slot_repr.Header.encoding))\n (function\n | Dal_register_invalid_slot_header {length; slot_header} ->\n Some (length, slot_header)\n | _ -> None)\n (fun (length, slot_header) ->\n Dal_register_invalid_slot_header {length; slot_header})\n\n let record_available_shards ctxt slots shards =\n let dal_attestation_slot_accountability =\n Dal_attestation_repr.Accountability.record_shards_availability\n ctxt.back.dal_attestation_slot_accountability\n slots\n shards\n in\n {ctxt with back = {ctxt.back with dal_attestation_slot_accountability}}\n\n let register_slot_header ctxt slot_header =\n match\n Dal_slot_repr.Slot_market.register\n ctxt.back.dal_slot_fee_market\n slot_header\n with\n | None ->\n let length =\n Dal_slot_repr.Slot_market.length ctxt.back.dal_slot_fee_market\n in\n error (Dal_register_invalid_slot_header {length; slot_header})\n | Some (dal_slot_fee_market, updated) ->\n ok ({ctxt with back = {ctxt.back with dal_slot_fee_market}}, updated)\n\n let candidates ctxt =\n Dal_slot_repr.Slot_market.candidates ctxt.back.dal_slot_fee_market\n\n let is_slot_index_available ctxt =\n let threshold =\n ctxt.back.constants.Constants_parametric_repr.dal.availability_threshold\n in\n let number_of_shards =\n ctxt.back.constants.Constants_parametric_repr.dal.cryptobox_parameters\n .number_of_shards\n in\n Dal_attestation_repr.Accountability.is_slot_available\n ctxt.back.dal_attestation_slot_accountability\n ~threshold\n ~number_of_shards\n\n type committee = dal_committee = {\n pkh_to_shards :\n (Dal_attestation_repr.shard_index * int) Signature.Public_key_hash.Map.t;\n shard_to_pkh : Signature.Public_key_hash.t Dal_attestation_repr.Shard_map.t;\n }\n\n (* DAL/FIXME https://gitlab.com/tezos/tezos/-/issues/3110\n\n A committee is selected by the callback function\n [pkh_from_tenderbake_slot]. We use a callback because of circular\n dependencies. It is not clear whether it will be the final choice\n for the DAL committee. The current solution is a bit hackish but\n should work. If we decide to differ from the Tenderbake\n committee, one could just draw a new committee.\n\n The problem with drawing a new committee is that it is not\n guaranteed that everyone in the DAL committee will be in the\n Tenderbake committee. Consequently, either we decide to have a\n new consensus operation which does not count for Tenderbake,\n and/or we take into account for the model of DAL that at every\n level, a percentage of DAL attestations cannot be received. *)\n let compute_committee ctxt pkh_from_tenderbake_slot =\n let Constants_parametric_repr.\n {\n dal = {cryptobox_parameters = {number_of_shards; _}; _};\n consensus_committee_size;\n _;\n } =\n ctxt.back.constants\n in\n (* We first draw a committee by drawing slots from the Tenderbake\n committee. To have a compact representation of slots, we can\n sort the Tenderbake slots by [pkh], so that a committee is\n actually only an interval. This is done by recomputing a\n committee from the first one. *)\n let update_committee committee pkh ~slot_index ~power =\n {\n pkh_to_shards =\n Signature.Public_key_hash.Map.update\n pkh\n (function\n | None -> Some (slot_index, power)\n | Some (initial_shard_index, old_power) ->\n Some (initial_shard_index, old_power + power))\n committee.pkh_to_shards;\n shard_to_pkh =\n List.fold_left\n (fun shard_to_pkh slot ->\n Dal_attestation_repr.Shard_map.add slot pkh shard_to_pkh)\n committee.shard_to_pkh\n Misc.(slot_index --> (slot_index + (power - 1)));\n }\n in\n let rec compute_power index committee =\n if Compare.Int.(index < 0) then return committee\n else\n let shard_index = index mod consensus_committee_size in\n Slot_repr.of_int shard_index >>?= fun slot ->\n pkh_from_tenderbake_slot slot >>=? fun (_ctxt, pkh) ->\n (* The [Slot_repr] module is related to the Tenderbake committee. *)\n let slot_index = Slot_repr.to_int slot in\n (* An optimisation could be to return only [pkh_to_shards] map\n because the second one is not used. This can be done later\n on if it is a good optimisation. *)\n let committee = update_committee committee pkh ~slot_index ~power:1 in\n compute_power (index - 1) committee\n in\n (* This committee is an intermediate to compute the final DAL\n commitee. This one only projects the Tenderbake committee into\n the DAL committee. The next one reorder the slots so that they\n are grouped by public key hash. *)\n compute_power (number_of_shards - 1) empty_dal_committee\n >>=? fun unordered_committee ->\n let dal_committee =\n Signature.Public_key_hash.Map.fold\n (fun pkh (_, power) (total_power, committee) ->\n let committee =\n update_committee committee pkh ~slot_index:total_power ~power\n in\n let new_total_power = total_power + power in\n (new_total_power, committee))\n unordered_committee.pkh_to_shards\n (0, empty_dal_committee)\n |> snd\n in\n return dal_committee\n\n let init_committee ctxt committee =\n {ctxt with back = {ctxt.back with dal_committee = committee}}\n\n let shards_of_attestor ctxt ~attestor:pkh =\n let rec make acc (initial_shard_index, power) =\n if Compare.Int.(power <= 0) then List.rev acc\n else make (initial_shard_index :: acc) (initial_shard_index + 1, power - 1)\n in\n Signature.Public_key_hash.Map.find_opt\n pkh\n ctxt.back.dal_committee.pkh_to_shards\n |> Option.map (fun pre_shards -> make [] pre_shards)\nend\n\n(* The type for relative context accesses instead from the root. In order for\n the carbonated storage functions to consume the gas, this has gas infomation\n*)\ntype local_context = {\n tree : tree;\n path : key;\n remaining_operation_gas : Gas_limit_repr.Arith.fp;\n unlimited_operation_gas : bool;\n}\n\nlet with_local_context ctxt key f =\n (find_tree ctxt key >|= function None -> Tree.empty ctxt | Some tree -> tree)\n >>= fun tree ->\n let local_ctxt =\n {\n tree;\n path = key;\n remaining_operation_gas = remaining_operation_gas ctxt;\n unlimited_operation_gas = unlimited_operation_gas ctxt;\n }\n in\n f local_ctxt >>=? fun (local_ctxt, res) ->\n add_tree ctxt key local_ctxt.tree >|= fun ctxt ->\n update_remaining_operation_gas ctxt local_ctxt.remaining_operation_gas\n |> fun ctxt ->\n update_unlimited_operation_gas ctxt local_ctxt.unlimited_operation_gas\n |> fun ctxt -> ok (ctxt, res)\n\nmodule Local_context : sig\n include\n Raw_context_intf.VIEW\n with type t = local_context\n and type key := key\n and type value := value\n and type tree := tree\n\n val consume_gas :\n local_context -> Gas_limit_repr.cost -> local_context tzresult\n\n val absolute_key : local_context -> key -> key\nend = struct\n type t = local_context\n\n let consume_gas local cost =\n match Gas_limit_repr.raw_consume local.remaining_operation_gas cost with\n | Some gas_counter -> Ok {local with remaining_operation_gas = gas_counter}\n | None ->\n if local.unlimited_operation_gas then ok local\n else error Operation_quota_exceeded\n\n let tree local = local.tree\n\n let update_root_tree local tree = {local with tree}\n\n let absolute_key local key = local.path @ key\n\n let find local = Tree.find (tree local)\n\n let find_tree local = Tree.find_tree (tree local)\n\n let mem local = Tree.mem (tree local)\n\n let mem_tree local = Tree.mem_tree (tree local)\n\n let get local = Tree.get (tree local)\n\n let get_tree local = Tree.get_tree (tree local)\n\n let update local key b =\n Tree.update (tree local) key b >|=? update_root_tree local\n\n let update_tree local key b =\n Tree.update_tree (tree local) key b >|=? update_root_tree local\n\n let init local key b =\n Tree.init (tree local) key b >|=? update_root_tree local\n\n let init_tree local key t =\n Tree.init_tree (tree local) key t >|=? update_root_tree local\n\n let add local i b = Tree.add (tree local) i b >|= update_root_tree local\n\n let add_tree local i t =\n Tree.add_tree (tree local) i t >|= update_root_tree local\n\n let remove local i = Tree.remove (tree local) i >|= update_root_tree local\n\n let remove_existing local key =\n Tree.remove_existing (tree local) key >|=? update_root_tree local\n\n let remove_existing_tree local key =\n Tree.remove_existing_tree (tree local) key >|=? update_root_tree local\n\n let add_or_remove local key vopt =\n Tree.add_or_remove (tree local) key vopt >|= update_root_tree local\n\n let add_or_remove_tree local key topt =\n Tree.add_or_remove_tree (tree local) key topt >|= update_root_tree local\n\n let fold ?depth local key ~order ~init ~f =\n Tree.fold ?depth (tree local) key ~order ~init ~f\n\n let list local ?offset ?length key =\n Tree.list (tree local) ?offset ?length key\n\n let config local = Tree.config (tree local)\n\n let length local i = Tree.length (tree local) i\nend\n" ;
} ;
{ name = "Storage_costs" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2020 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Cost of reading [read_bytes] at a key of length [path_length]. *)\nval read_access : path_length:int -> read_bytes:int -> Gas_limit_repr.cost\n\n(** Cost of performing a single write access, writing [written_bytes] bytes. *)\nval write_access : written_bytes:int -> Gas_limit_repr.cost\n\n(** [list_key_values_traverse ~size] returns the cost of traversing a context\n with [size] number of elements. *)\nval list_key_values_traverse : size:int -> Gas_limit_repr.cost\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2020 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(* The model for read accesses is the following:\n\n cost(path_length, read_bytes) = 200_000 + 5000 * path_length + 2 * read_bytes\n*)\nlet read_access ~path_length ~read_bytes =\n let open Saturation_repr in\n let base_cost = safe_int (200_000 + (5000 * path_length)) in\n Gas_limit_repr.atomic_step_cost\n (add base_cost (mul (safe_int 2) (safe_int read_bytes)))\n\n(* The model for write accesses is the following:\n\n cost(written_bytes) = 200_000 + 4 * written_bytes\n*)\nlet write_access ~written_bytes =\n let open Saturation_repr in\n Gas_limit_repr.atomic_step_cost\n (add (safe_int 200_000) (mul (safe_int 4) (safe_int written_bytes)))\n\nlet list_key_values_step_cost = Saturation_repr.safe_int 117\n\nlet list_key_values_intercept = Saturation_repr.safe_int 470\n\nlet list_key_values_traverse ~size =\n Saturation_repr.(\n add\n list_key_values_intercept\n (mul (safe_int size) list_key_values_step_cost))\n" ;
} ;
{ name = "Storage_sigs" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2019-2020 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** {1 Entity Accessor Signatures} *)\n\n(** The generic signature of a single data accessor (a single value\n bound to a specific key in the hierarchical (key x value)\n database). *)\nmodule type Single_data_storage = sig\n type t\n\n type context = t\n\n (** The type of the value *)\n type value\n\n (** Tells if the data is already defined *)\n val mem : context -> bool Lwt.t\n\n (** Retrieve the value from the storage bucket ; returns a\n {!Storage_error} if the key is not set or if the deserialisation\n fails *)\n val get : context -> value tzresult Lwt.t\n\n (** Retrieves the value from the storage bucket ; returns [None] if\n the data is not initialized, or {!Storage_helpers.Storage_error}\n if the deserialisation fails *)\n val find : context -> value option tzresult Lwt.t\n\n (** Allocates the storage bucket and initializes it ; returns a\n {!Storage_error Existing_key} if the bucket exists *)\n val init : context -> value -> Raw_context.t tzresult Lwt.t\n\n (** Updates the content of the bucket ; returns a {!Storage_Error\n Missing_key} if the value does not exists *)\n val update : context -> value -> Raw_context.t tzresult Lwt.t\n\n (** Allocates the data and initializes it with a value ; just\n updates it if the bucket exists *)\n val add : context -> value -> Raw_context.t Lwt.t\n\n (** When the value is [Some v], allocates the data and initializes\n it with [v] ; just updates it if the bucket exists. When the\n value is [None], delete the storage bucket when the value ; does\n nothing if the bucket does not exists. *)\n val add_or_remove : context -> value option -> Raw_context.t Lwt.t\n\n (** Delete the storage bucket ; returns a {!Storage_error\n Missing_key} if the bucket does not exists *)\n val remove_existing : context -> Raw_context.t tzresult Lwt.t\n\n (** Removes the storage bucket and its contents ; does nothing if\n the bucket does not exists *)\n val remove : context -> Raw_context.t Lwt.t\nend\n\n(** Restricted version of {!Indexed_data_storage} w/o iterators. *)\nmodule type Non_iterable_indexed_data_storage = sig\n type t\n\n type context = t\n\n (** An abstract type for keys *)\n type key\n\n (** The type of values *)\n type value\n\n (** Tells if a given key is already bound to a storage bucket *)\n val mem : context -> key -> bool Lwt.t\n\n (** Retrieve a value from the storage bucket at a given key ;\n returns {!Storage_error Missing_key} if the key is not set ;\n returns {!Storage_error Corrupted_data} if the deserialisation\n fails. *)\n val get : context -> key -> value tzresult Lwt.t\n\n (** Retrieve a value from the storage bucket at a given key ;\n returns [None] if the value is not set ; returns {!Storage_error\n Corrupted_data} if the deserialisation fails. *)\n val find : context -> key -> value option tzresult Lwt.t\n\n (** Updates the content of a bucket ; returns A {!Storage_Error\n Missing_key} if the value does not exists. *)\n val update : context -> key -> value -> Raw_context.t tzresult Lwt.t\n\n (** Allocates a storage bucket at the given key and initializes it ;\n returns a {!Storage_error Existing_key} if the bucket exists. *)\n val init : context -> key -> value -> Raw_context.t tzresult Lwt.t\n\n (** Allocates a storage bucket at the given key and initializes it\n with a value ; just updates it if the bucket exists. *)\n val add : context -> key -> value -> Raw_context.t Lwt.t\n\n (** When the value is [Some v], allocates the data and initializes\n it with [v] ; just updates it if the bucket exists. When the\n value is [None], delete the storage bucket when the value ; does\n nothing if the bucket does not exists. *)\n val add_or_remove : context -> key -> value option -> Raw_context.t Lwt.t\n\n (** Delete a storage bucket and its contents ; returns a\n {!Storage_error Missing_key} if the bucket does not exists. *)\n val remove_existing : context -> key -> Raw_context.t tzresult Lwt.t\n\n (** Removes a storage bucket and its contents ; does nothing if the\n bucket does not exists. *)\n val remove : context -> key -> Raw_context.t Lwt.t\nend\n\n(** Variant of {!Non_iterable_indexed_data_storage} with gas accounting. *)\nmodule type Non_iterable_indexed_carbonated_data_storage = sig\n type t\n\n type context = t\n\n (** An abstract type for keys *)\n type key\n\n (** The type of values *)\n type value\n\n (** Tells if a given key is already bound to a storage bucket.\n Consumes [Gas_repr.read_bytes_cost Z.zero]. *)\n val mem : context -> key -> (Raw_context.t * bool) tzresult Lwt.t\n\n (** Retrieve a value from the storage bucket at a given key ;\n returns {!Storage_error Missing_key} if the key is not set ;\n returns {!Storage_error Corrupted_data} if the deserialisation\n fails.\n Consumes [Gas_repr.read_bytes_cost <size of the value>]. *)\n val get : context -> key -> (Raw_context.t * value) tzresult Lwt.t\n\n (** Retrieve a value from the storage bucket at a given key ;\n returns [None] if the value is not set ; returns {!Storage_error\n Corrupted_data} if the deserialisation fails.\n Consumes [Gas_repr.read_bytes_cost <size of the value>] if present\n or [Gas_repr.read_bytes_cost Z.zero]. *)\n val find : context -> key -> (Raw_context.t * value option) tzresult Lwt.t\n\n (** Updates the content of a bucket ; returns A {!Storage_Error\n Missing_key} if the value does not exists.\n Consumes serialization cost.\n Consumes [Gas_repr.write_bytes_cost <size of the new value>].\n Returns the difference from the old to the new size. *)\n val update : context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t\n\n (** Allocates a storage bucket at the given key and initializes it ;\n returns a {!Storage_error Existing_key} if the bucket exists.\n Consumes serialization cost.\n Consumes [Gas_repr.write_bytes_cost <size of the value>].\n Returns the size. *)\n val init : context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t\n\n (** Allocates a storage bucket at the given key and initializes it\n with a value ; just updates it if the bucket exists.\n Consumes serialization cost.\n Consumes [Gas_repr.write_bytes_cost <size of the new value>].\n Returns the difference from the old (maybe 0) to the new size, and a boolean\n indicating if a value was already associated to this key. *)\n val add :\n context -> key -> value -> (Raw_context.t * int * bool) tzresult Lwt.t\n\n (** When the value is [Some v], allocates the data and initializes\n it with [v] ; just updates it if the bucket exists. When the\n value is [None], delete the storage bucket when the value ; does\n nothing if the bucket does not exists.\n Consumes serialization cost.\n Consumes the same gas cost as either {!remove} or {!init_set}.\n Returns the difference from the old (maybe 0) to the new size, and a boolean\n indicating if a value was already associated to this key. *)\n val add_or_remove :\n context ->\n key ->\n value option ->\n (Raw_context.t * int * bool) tzresult Lwt.t\n\n (** Delete a storage bucket and its contents ; returns a\n {!Storage_error Missing_key} if the bucket does not exists.\n Consumes [Gas_repr.write_bytes_cost Z.zero].\n Returns the freed size. *)\n val remove_existing : context -> key -> (Raw_context.t * int) tzresult Lwt.t\n\n (** Removes a storage bucket and its contents ; does nothing if the\n bucket does not exists.\n Consumes [Gas_repr.write_bytes_cost Z.zero].\n Returns the freed size, and a boolean\n indicating if a value was already associated to this key. *)\n val remove : context -> key -> (Raw_context.t * int * bool) tzresult Lwt.t\n\n (** Returns the list of all storage bucket keys.\n Not carbonated (i.e. gas is not consumed); use with care. *)\n val keys_unaccounted : context -> key list Lwt.t\nend\n\nmodule type Indexed_carbonated_data_storage = sig\n include Non_iterable_indexed_carbonated_data_storage\n\n (** [list_key_values ?offset ?length storage] lists the key and value pairs of\n each entry in the given [storage]. The first [offset] values are ignored\n (if passed). Negative offsets are treated as [0]. There will be no more\n than [length] values in the result list (if passed). Negative values are\n treated as [0].\n\n The returned {!context} takes into account gas consumption of traversing\n the keys and loading values. *)\n val list_key_values :\n ?offset:int ->\n ?length:int ->\n t ->\n (Raw_context.t * (key * value) list) tzresult Lwt.t\n\n (** Returns [true] iff [context] is empty. *)\n val is_empty : context -> bool Lwt.t\nend\n\nmodule type Indexed_carbonated_data_storage_INTERNAL = sig\n include Indexed_carbonated_data_storage\n\n val fold_keys_unaccounted :\n context ->\n order:[`Sorted | `Undefined] ->\n init:'a ->\n f:(key -> 'a -> 'a Lwt.t) ->\n 'a Lwt.t\nend\n\n(** The generic signature of indexed data accessors (a set of values\n of the same type indexed by keys of the same form in the\n hierarchical (key x value) database). *)\nmodule type Indexed_data_storage = sig\n include Non_iterable_indexed_data_storage\n\n (** Empties all the keys and associated data. *)\n val clear : context -> Raw_context.t Lwt.t\n\n (** Lists all the keys. *)\n val keys : context -> key list Lwt.t\n\n (** Lists all the keys and associated data. *)\n val bindings : context -> (key * value) list Lwt.t\n\n (** Iterates over all the keys and associated data. *)\n val fold :\n context ->\n order:[`Sorted | `Undefined] ->\n init:'a ->\n f:(key -> value -> 'a -> 'a Lwt.t) ->\n 'a Lwt.t\n\n (** Iterate over all the keys. *)\n val fold_keys :\n context ->\n order:[`Sorted | `Undefined] ->\n init:'a ->\n f:(key -> 'a -> 'a Lwt.t) ->\n 'a Lwt.t\n\n (** Returns [true] iff [context] is empty. *)\n val is_empty : context -> bool Lwt.t\nend\n\nmodule type Indexed_data_storage_with_local_context = sig\n include Indexed_data_storage\n\n type local_context\n\n module Local : sig\n type context = local_context\n\n (** Tells if the data is already defined *)\n val mem : context -> bool Lwt.t\n\n (** Retrieves the value from the storage bucket; returns a\n {!Storage_error} if the key is not set or if the deserialisation\n fails *)\n val get : context -> value tzresult Lwt.t\n\n (** Retrieves the value from the storage bucket ; returns [None] if\n the data is not initialized, or {!Storage_helpers.Storage_error}\n if the deserialisation fails *)\n val find : context -> value option tzresult Lwt.t\n\n (** Allocates the storage bucket and initializes it ; returns a\n {!Storage_error Existing_key} if the bucket exists *)\n val init : context -> value -> context tzresult Lwt.t\n\n (** Updates the content of the bucket; returns a {!Storage_Error\n Missing_key} if the value does not exist *)\n val update : context -> value -> context tzresult Lwt.t\n\n (** Allocates the data and initializes it with a value ; just\n updates it if the bucket exists *)\n val add : context -> value -> context Lwt.t\n\n (** When the value is [Some v], allocates the data and initializes\n it with [v] ; just updates it if the bucket exists. When the\n value is [None], deletes the storage bucket; it does\n nothing if the bucket does not exists. *)\n val add_or_remove : context -> value option -> context Lwt.t\n\n (** Delete the storage bucket ; returns a {!Storage_error\n Missing_key} if the bucket does not exists *)\n val remove_existing : context -> context tzresult Lwt.t\n\n (** Removes the storage bucket and its contents; does nothing if\n the bucket does not exist *)\n val remove : context -> context Lwt.t\n end\nend\n\nmodule type Indexed_data_snapshotable_storage = sig\n type snapshot\n\n type key\n\n include Indexed_data_storage with type key := key\n\n module Snapshot :\n Indexed_data_storage\n with type key = snapshot * key\n and type value = value\n and type t = t\n\n val snapshot_exists : context -> snapshot -> bool Lwt.t\n\n val snapshot : context -> snapshot -> Raw_context.t tzresult Lwt.t\n\n val fold_snapshot :\n context ->\n snapshot ->\n order:[`Sorted | `Undefined] ->\n init:'a ->\n f:(key -> value -> 'a -> 'a tzresult Lwt.t) ->\n 'a tzresult Lwt.t\n\n val delete_snapshot : context -> snapshot -> Raw_context.t Lwt.t\nend\n\n(** The generic signature of a data set accessor (a set of values\n bound to a specific key prefix in the hierarchical (key x value)\n database). *)\nmodule type Data_set_storage = sig\n type t\n\n type context = t\n\n (** The type of elements. *)\n type elt\n\n (** Tells if a elt is a member of the set *)\n val mem : context -> elt -> bool Lwt.t\n\n (** Adds a elt is a member of the set *)\n val add : context -> elt -> Raw_context.t Lwt.t\n\n (** Removes a elt of the set ; does nothing if not a member *)\n val remove : context -> elt -> Raw_context.t Lwt.t\n\n (** Returns the elements of the set, deserialized in a list in no\n particular order. *)\n val elements : context -> elt list Lwt.t\n\n (** Iterates over the elements of the set. *)\n val fold :\n context ->\n order:[`Sorted | `Undefined] ->\n init:'a ->\n f:(elt -> 'a -> 'a Lwt.t) ->\n 'a Lwt.t\n\n (** Removes all elements in the set *)\n val clear : context -> Raw_context.t Lwt.t\nend\n\n(** Variant of {!Data_set_storage} with gas accounting. *)\nmodule type Carbonated_data_set_storage = sig\n type t\n\n type context = t\n\n (** The type of elements. *)\n type elt\n\n (** Tells whether an elt is a member of the set.\n Consumes [Gas_repr.read_bytes_cost Z.zero] *)\n val mem : context -> elt -> (Raw_context.t * bool) tzresult Lwt.t\n\n (** Adds an elt as a member of the set.\n Consumes [Gas_repr.write_bytes_cost <size of the new value>].\n Returns the the new size. *)\n val init : context -> elt -> (Raw_context.t * int) tzresult Lwt.t\n\n (** Adds an elt as a member of the set.\n Consumes [Gas_repr.write_bytes_cost <size of the new value>].\n Returns the new size, and true if the value previously existed. *)\n val add : context -> elt -> (Raw_context.t * int * bool) tzresult Lwt.t\n\n (** Removes an elt from the set ; does nothing if not a member.\n Consumes [Gas_repr.write_bytes_cost Z.zero].\n Returns the freed size, and a boolean\n indicating if a value was already associated to this key. *)\n val remove : context -> elt -> (Raw_context.t * int * bool) tzresult Lwt.t\n\n val fold_keys_unaccounted :\n context ->\n order:[`Sorted | `Undefined] ->\n init:'acc ->\n f:(elt -> 'acc -> 'acc Lwt.t) ->\n 'acc Lwt.t\nend\n\nmodule type NAME = sig\n val name : Raw_context.key\nend\n\nmodule type VALUE = sig\n type t\n\n val encoding : t Data_encoding.t\nend\n\nmodule type REGISTER = sig\n val ghost : bool\nend\n\nmodule type Indexed_raw_context = sig\n type t\n\n type context = t\n\n type key\n\n type 'a ipath\n\n type local_context\n\n val clear : context -> Raw_context.t Lwt.t\n\n val is_empty : context -> bool Lwt.t\n\n val fold_keys :\n context ->\n order:[`Sorted | `Undefined] ->\n init:'a ->\n f:(key -> 'a -> 'a Lwt.t) ->\n 'a Lwt.t\n\n val keys : context -> key list Lwt.t\n\n val remove : context -> key -> context Lwt.t\n\n val copy : context -> from:key -> to_:key -> context tzresult Lwt.t\n\n val with_local_context :\n context ->\n key ->\n (local_context -> (local_context * 'a) tzresult Lwt.t) ->\n (context * 'a) tzresult Lwt.t\n\n module Make_set (_ : REGISTER) (_ : NAME) :\n Data_set_storage with type t = t and type elt = key\n\n module Make_map (_ : REGISTER) (_ : NAME) (V : VALUE) :\n Indexed_data_storage_with_local_context\n with type t = t\n and type key = key\n and type value = V.t\n and type local_context = local_context\n\n module Make_carbonated_map (_ : REGISTER) (_ : NAME) (V : VALUE) :\n Non_iterable_indexed_carbonated_data_storage\n with type t = t\n and type key = key\n and type value = V.t\n\n module Raw_context : Raw_context.T with type t = t ipath\nend\n" ;
} ;
{ name = "Storage_functors" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2019-2020 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Tezos Protocol Implementation - Typed storage builders.\n\n Contains functors used by [Storage] to create the structure on\n disk.\n\n See {!Make_subcontext}\n *)\n\nopen Storage_sigs\n\nmodule Registered : REGISTER\n\nmodule Ghost : REGISTER\n\n(** Given a [Raw_context], return a new [Raw_context] that projects into\n a given subtree. Similar to a {i functional lens}.\n *)\nmodule Make_subcontext (_ : REGISTER) (C : Raw_context.T) (_ : NAME) :\n Raw_context.T with type t = C.t\n\nmodule Make_single_data_storage\n (_ : REGISTER)\n (C : Raw_context.T)\n (_ : NAME)\n (V : VALUE) : Single_data_storage with type t = C.t and type value = V.t\n\n(** A type that can be serialized as a [string list], and used\n as a prefix in the typed datastore.\n\n Useful to implement storage of maps and sets.\n *)\nmodule type INDEX = sig\n type t\n\n include Path_encoding.S with type t := t\n\n type 'a ipath\n\n val args : ('a, t, 'a ipath) Storage_description.args\nend\n\nmodule Pair (I1 : INDEX) (I2 : INDEX) : INDEX with type t = I1.t * I2.t\n\n(** Create storage for a compound type. *)\nmodule Make_data_set_storage (C : Raw_context.T) (I : INDEX) :\n Data_set_storage with type t = C.t and type elt = I.t\n\n(** Like [Make_data_set_storage], adding tracking of storage cost. *)\nmodule Make_carbonated_data_set_storage (C : Raw_context.T) (I : INDEX) :\n Carbonated_data_set_storage with type t = C.t and type elt = I.t\n\n(** This functor creates storage for types with a notion of an index. *)\nmodule Make_indexed_data_storage (C : Raw_context.T) (I : INDEX) (V : VALUE) :\n Indexed_data_storage with type t = C.t and type key = I.t and type value = V.t\n\n(** Like [Make_indexed_data_storage], adding tracking of storage cost. *)\nmodule Make_indexed_carbonated_data_storage\n (C : Raw_context.T)\n (I : INDEX)\n (V : VALUE) :\n Indexed_carbonated_data_storage\n with type t = C.t\n and type key = I.t\n and type value = V.t\n\nmodule Make_indexed_data_snapshotable_storage\n (C : Raw_context.T)\n (Snapshot : INDEX)\n (I : INDEX)\n (V : VALUE) :\n Indexed_data_snapshotable_storage\n with type t = C.t\n and type snapshot = Snapshot.t\n and type key = I.t\n and type value = V.t\n\nmodule Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) :\n Indexed_raw_context\n with type t = C.t\n and type key = I.t\n and type 'a ipath = 'a I.ipath\n\nmodule type WRAPPER = sig\n type t\n\n type key\n\n val wrap : t -> key\n\n val unwrap : key -> t option\nend\n\nmodule Wrap_indexed_data_storage\n (C : Indexed_data_storage)\n (K : WRAPPER with type key := C.key) :\n Indexed_data_storage\n with type t = C.t\n and type key = K.t\n and type value = C.value\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2019-2020 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Storage_sigs\n\nmodule Registered = struct\n let ghost = false\nend\n\nmodule Ghost = struct\n let ghost = true\nend\n\nmodule type ENCODER = sig\n type t\n\n val of_bytes : key:(unit -> string list) -> bytes -> t tzresult\n\n val to_bytes : t -> bytes\nend\n\nmodule Make_encoder (V : VALUE) : ENCODER with type t := V.t = struct\n let of_bytes ~key b =\n match Data_encoding.Binary.of_bytes_opt V.encoding b with\n | None -> error (Raw_context.Storage_error (Corrupted_data (key ())))\n | Some v -> Ok v\n\n let to_bytes v =\n match Data_encoding.Binary.to_bytes_opt V.encoding v with\n | Some b -> b\n | None -> Bytes.empty\nend\n\nlet len_name = \"len\"\n\nlet data_name = \"data\"\n\nlet encode_len_value bytes =\n let length = Bytes.length bytes in\n Data_encoding.(Binary.to_bytes_exn int31) length\n\nlet decode_len_value key len =\n match Data_encoding.(Binary.of_bytes_opt int31) len with\n | None -> error (Raw_context.Storage_error (Corrupted_data key))\n | Some len -> ok len\n\nmodule Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME) :\n Raw_context.T with type t = C.t and type local_context = C.local_context =\nstruct\n type t = C.t\n\n type local_context = C.local_context\n\n let to_key k = N.name @ k\n\n let mem t k = C.mem t (to_key k)\n\n let mem_tree t k = C.mem_tree t (to_key k)\n\n let get t k = C.get t (to_key k)\n\n let get_tree t k = C.get_tree t (to_key k)\n\n let find t k = C.find t (to_key k)\n\n let find_tree t k = C.find_tree t (to_key k)\n\n let add t k v = C.add t (to_key k) v\n\n let add_tree t k v = C.add_tree t (to_key k) v\n\n let init t k v = C.init t (to_key k) v\n\n let init_tree t k v = C.init_tree t (to_key k) v\n\n let update t k v = C.update t (to_key k) v\n\n let update_tree t k v = C.update_tree t (to_key k) v\n\n let add_or_remove t k v = C.add_or_remove t (to_key k) v\n\n let add_or_remove_tree t k v = C.add_or_remove_tree t (to_key k) v\n\n let remove_existing t k = C.remove_existing t (to_key k)\n\n let remove_existing_tree t k = C.remove_existing_tree t (to_key k)\n\n let remove t k = C.remove t (to_key k)\n\n let list t ?offset ?length k = C.list t ?offset ?length (to_key k)\n\n let fold ?depth t k ~order ~init ~f =\n C.fold ?depth t (to_key k) ~order ~init ~f\n\n let config t = C.config t\n\n module Tree = C.Tree\n module Proof = C.Proof\n\n let verify_tree_proof = C.verify_tree_proof\n\n let verify_stream_proof = C.verify_stream_proof\n\n let equal_config = C.equal_config\n\n let project = C.project\n\n let absolute_key c k = C.absolute_key c (to_key k)\n\n type error += Block_quota_exceeded = C.Block_quota_exceeded\n\n type error += Operation_quota_exceeded = C.Operation_quota_exceeded\n\n let consume_gas = C.consume_gas\n\n let check_enough_gas = C.check_enough_gas\n\n let description =\n let description =\n if R.ghost then Storage_description.create () else C.description\n in\n Storage_description.register_named_subcontext description N.name\n\n let length = C.length\n\n let with_local_context ctxt k f = C.with_local_context ctxt (to_key k) f\n\n module Local_context = C.Local_context\nend\n\nmodule Make_single_data_storage\n (R : REGISTER)\n (C : Raw_context.T)\n (N : NAME)\n (V : VALUE) : Single_data_storage with type t = C.t and type value = V.t =\nstruct\n type t = C.t\n\n type context = t\n\n type value = V.t\n\n let mem t = C.mem t N.name\n\n include Make_encoder (V)\n\n let get t =\n C.get t N.name >>=? fun b ->\n let key () = C.absolute_key t N.name in\n Lwt.return (of_bytes ~key b)\n\n let find t =\n C.find t N.name >|= function\n | None -> Result.return_none\n | Some b ->\n let key () = C.absolute_key t N.name in\n of_bytes ~key b >|? fun v -> Some v\n\n let init t v = C.init t N.name (to_bytes v) >|=? fun t -> C.project t\n\n let update t v = C.update t N.name (to_bytes v) >|=? fun t -> C.project t\n\n let add t v = C.add t N.name (to_bytes v) >|= fun t -> C.project t\n\n let add_or_remove t v =\n C.add_or_remove t N.name (Option.map to_bytes v) >|= fun t -> C.project t\n\n let remove t = C.remove t N.name >|= fun t -> C.project t\n\n let remove_existing t = C.remove_existing t N.name >|=? fun t -> C.project t\n\n let () =\n let open Storage_description in\n let description =\n if R.ghost then Storage_description.create () else C.description\n in\n register_value\n ~get:find\n (register_named_subcontext description N.name)\n V.encoding\nend\n\nmodule type INDEX = sig\n type t\n\n include Path_encoding.S with type t := t\n\n type 'a ipath\n\n val args : ('a, t, 'a ipath) Storage_description.args\nend\n\nmodule Pair (I1 : INDEX) (I2 : INDEX) : INDEX with type t = I1.t * I2.t = struct\n type t = I1.t * I2.t\n\n let path_length = I1.path_length + I2.path_length\n\n let to_path (x, y) l = I1.to_path x (I2.to_path y l)\n\n let of_path l =\n match Misc.take I1.path_length l with\n | None -> None\n | Some (l1, l2) -> (\n match (I1.of_path l1, I2.of_path l2) with\n | Some x, Some y -> Some (x, y)\n | _ -> None)\n\n type 'a ipath = 'a I1.ipath I2.ipath\n\n let args = Storage_description.Pair (I1.args, I2.args)\nend\n\nmodule Make_data_set_storage (C : Raw_context.T) (I : INDEX) :\n Data_set_storage with type t = C.t and type elt = I.t = struct\n type t = C.t\n\n type context = t\n\n type elt = I.t\n\n let inited = Bytes.of_string \"inited\"\n\n let mem s i = C.mem s (I.to_path i [])\n\n let add s i = C.add s (I.to_path i []) inited >|= fun t -> C.project t\n\n let remove s i = C.remove s (I.to_path i []) >|= fun t -> C.project t\n\n let clear s = C.remove s [] >|= fun t -> C.project t\n\n let fold s ~order ~init ~f =\n C.fold ~depth:(`Eq I.path_length) s [] ~order ~init ~f:(fun file tree acc ->\n match C.Tree.kind tree with\n | `Value -> (\n match I.of_path file with None -> assert false | Some p -> f p acc)\n | `Tree -> Lwt.return acc)\n\n let elements s =\n fold s ~order:`Sorted ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))\n\n let () =\n let open Storage_description in\n let unpack = unpack I.args in\n register_value (* TODO fixme 'elements...' *)\n ~get:(fun c ->\n let c, k = unpack c in\n mem c k >>= function true -> return_some true | false -> return_none)\n (register_indexed_subcontext\n ~list:(fun c -> elements c >|= ok)\n C.description\n I.args)\n Data_encoding.bool\nend\n\nmodule Make_indexed_data_storage (C : Raw_context.T) (I : INDEX) (V : VALUE) :\n Indexed_data_storage with type t = C.t and type key = I.t and type value = V.t =\nstruct\n type t = C.t\n\n type context = t\n\n type key = I.t\n\n type value = V.t\n\n include Make_encoder (V)\n\n let mem s i = C.mem s (I.to_path i [])\n\n let is_empty i =\n let open Lwt_syntax in\n let* root = C.find_tree i [] in\n match root with\n | None -> return_true\n | Some root -> return @@ C.Tree.is_empty root\n\n let get s i =\n C.get s (I.to_path i []) >>=? fun b ->\n let key () = C.absolute_key s (I.to_path i []) in\n Lwt.return (of_bytes ~key b)\n\n let find s i =\n C.find s (I.to_path i []) >|= function\n | None -> Result.return_none\n | Some b ->\n let key () = C.absolute_key s (I.to_path i []) in\n of_bytes ~key b >|? fun v -> Some v\n\n let update s i v =\n C.update s (I.to_path i []) (to_bytes v) >|=? fun t -> C.project t\n\n let init s i v =\n C.init s (I.to_path i []) (to_bytes v) >|=? fun t -> C.project t\n\n let add s i v = C.add s (I.to_path i []) (to_bytes v) >|= fun t -> C.project t\n\n let add_or_remove s i v =\n C.add_or_remove s (I.to_path i []) (Option.map to_bytes v) >|= fun t ->\n C.project t\n\n let remove s i = C.remove s (I.to_path i []) >|= fun t -> C.project t\n\n let remove_existing s i =\n C.remove_existing s (I.to_path i []) >|=? fun t -> C.project t\n\n let clear s = C.remove s [] >|= fun t -> C.project t\n\n let fold s ~order ~init ~f =\n C.fold ~depth:(`Eq I.path_length) s [] ~order ~init ~f:(fun file tree acc ->\n C.Tree.to_value tree >>= function\n | Some v -> (\n match I.of_path file with\n | None -> assert false\n | Some path -> (\n let key () = C.absolute_key s file in\n match of_bytes ~key v with\n | Ok v -> f path v acc\n | Error _ -> Lwt.return acc))\n | None -> Lwt.return acc)\n\n let fold_keys s ~order ~init ~f =\n fold s ~order ~init ~f:(fun k _ acc -> f k acc)\n\n let bindings s =\n fold s ~order:`Sorted ~init:[] ~f:(fun p v acc ->\n Lwt.return ((p, v) :: acc))\n\n let keys s =\n fold_keys s ~order:`Sorted ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))\n\n let () =\n let open Storage_description in\n let unpack = unpack I.args in\n register_value\n ~get:(fun c ->\n let c, k = unpack c in\n find c k)\n (register_indexed_subcontext\n ~list:(fun c -> keys c >|= ok)\n C.description\n I.args)\n V.encoding\nend\n\n(* Internal-use-only version of {!Make_indexed_carbonated_data_storage} to\n expose fold_keys_unaccounted *)\nmodule Make_indexed_carbonated_data_storage_INTERNAL\n (C : Raw_context.T)\n (I : INDEX)\n (V : VALUE) :\n Indexed_carbonated_data_storage_INTERNAL\n with type t = C.t\n and type key = I.t\n and type value = V.t = struct\n type t = C.t\n\n type context = t\n\n type key = I.t\n\n type value = V.t\n\n include Make_encoder (V)\n\n let is_empty i =\n let open Lwt_syntax in\n let* root = C.find_tree i [] in\n match root with\n | None -> return_true\n | Some root -> return @@ C.Tree.is_empty root\n\n let data_key i = I.to_path i [data_name]\n\n let len_key i = I.to_path i [len_name]\n\n let consume_mem_gas c key =\n let path_length = List.length @@ C.absolute_key c key in\n C.consume_gas c (Storage_costs.read_access ~path_length ~read_bytes:0)\n\n let existing_size c i =\n C.find c (len_key i) >|= function\n | None -> ok (0, false)\n | Some len -> decode_len_value (len_key i) len >|? fun len -> (len, true)\n\n let consume_read_gas get c i =\n let len_key = len_key i in\n get c len_key >>=? fun len ->\n let path_length = List.length @@ C.absolute_key c len_key in\n Lwt.return\n ( decode_len_value len_key len >>? fun read_bytes ->\n let cost = Storage_costs.read_access ~path_length ~read_bytes in\n C.consume_gas c cost )\n\n (* For the future: here, we bill a generic cost for encoding the value\n to bytes. It would be cleaner for users of this functor to provide\n gas costs for the encoding. *)\n let consume_serialize_write_gas set c i v =\n let bytes = to_bytes v in\n let len = Bytes.length bytes in\n C.consume_gas c (Gas_limit_repr.alloc_mbytes_cost len) >>?= fun c ->\n let cost = Storage_costs.write_access ~written_bytes:len in\n C.consume_gas c cost >>?= fun c ->\n set c (len_key i) (encode_len_value bytes) >|=? fun c -> (c, bytes)\n\n let consume_remove_gas del c i =\n C.consume_gas c (Storage_costs.write_access ~written_bytes:0) >>?= fun c ->\n del c (len_key i)\n\n let mem s i =\n let key = data_key i in\n consume_mem_gas s key >>?= fun s ->\n C.mem s key >|= fun exists -> ok (C.project s, exists)\n\n let get_unprojected s i =\n consume_read_gas C.get s i >>=? fun s ->\n C.get s (data_key i) >>=? fun b ->\n let key () = C.absolute_key s (data_key i) in\n Lwt.return (of_bytes ~key b >|? fun v -> (s, v))\n\n let get s i = get_unprojected s i >|=? fun (s, v) -> (C.project s, v)\n\n let find s i =\n let key = data_key i in\n consume_mem_gas s key >>?= fun s ->\n C.mem s key >>= fun exists ->\n if exists then get s i >|=? fun (s, v) -> (s, Some v)\n else return (C.project s, None)\n\n let update s i v =\n existing_size s i >>=? fun (prev_size, _) ->\n consume_serialize_write_gas C.update s i v >>=? fun (s, bytes) ->\n C.update s (data_key i) bytes >|=? fun t ->\n let size_diff = Bytes.length bytes - prev_size in\n (C.project t, size_diff)\n\n let init s i v =\n consume_serialize_write_gas C.init s i v >>=? fun (s, bytes) ->\n C.init s (data_key i) bytes >|=? fun t ->\n let size = Bytes.length bytes in\n (C.project t, size)\n\n let add s i v =\n let add s i v = C.add s i v >|= ok in\n existing_size s i >>=? fun (prev_size, existed) ->\n consume_serialize_write_gas add s i v >>=? fun (s, bytes) ->\n add s (data_key i) bytes >|=? fun t ->\n let size_diff = Bytes.length bytes - prev_size in\n (C.project t, size_diff, existed)\n\n let remove s i =\n let remove s i = C.remove s i >|= ok in\n existing_size s i >>=? fun (prev_size, existed) ->\n consume_remove_gas remove s i >>=? fun s ->\n remove s (data_key i) >|=? fun t -> (C.project t, prev_size, existed)\n\n let remove_existing s i =\n existing_size s i >>=? fun (prev_size, _) ->\n consume_remove_gas C.remove_existing s i >>=? fun s ->\n C.remove_existing s (data_key i) >|=? fun t -> (C.project t, prev_size)\n\n let add_or_remove s i v =\n match v with None -> remove s i | Some v -> add s i v\n\n (* TODO https://gitlab.com/tezos/tezos/-/issues/3318\n Switch implementation to use [C.list].\n Given that MR !2771 which flattens paths is done, we should use\n [C.list] to avoid having to iterate over all keys when [length] and/or\n [offset] is passed.\n *)\n let list_key_values ?(offset = 0) ?(length = max_int) s =\n let root = [] in\n let depth = `Eq I.path_length in\n C.length s root >>= fun size ->\n (* Regardless of the [length] argument, all elements stored in the context\n are traversed. We therefore pay a gas cost proportional to the number of\n elements, given by [size], upfront. We also pay gas for decoding elements\n whenever they are loaded in the body of the fold. *)\n C.consume_gas s (Storage_costs.list_key_values_traverse ~size) >>?= fun s ->\n C.fold\n s\n root\n ~depth\n ~order:`Sorted\n ~init:(ok (s, [], offset, length))\n ~f:(fun file tree acc ->\n match (C.Tree.kind tree, acc) with\n | `Tree, Ok (s, rev_values, offset, length) -> (\n if Compare.Int.(length <= 0) then\n (* Keep going until the end, we have no means of short-circuiting *)\n Lwt.return acc\n else if Compare.Int.(offset > 0) then\n (* Offset (first element) not reached yet *)\n let offset = pred offset in\n Lwt.return (Ok (s, rev_values, offset, length))\n else\n (* Nominal case *)\n match I.of_path file with\n | None -> assert false\n | Some key ->\n (* This also accounts for gas for loading the element. *)\n get_unprojected s key >|=? fun (s, value) ->\n (s, (key, value) :: rev_values, 0, pred length))\n | _ ->\n (* Even if we run out of gas or fail in some other way, we still\n traverse the whole tree. In this case there is no context to\n update. *)\n Lwt.return acc)\n >|=? fun (s, rev_values, _offset, _length) ->\n (C.project s, List.rev rev_values)\n\n let fold_keys_unaccounted s ~order ~init ~f =\n C.fold\n ~depth:(`Eq (1 + I.path_length))\n s\n []\n ~order\n ~init\n ~f:(fun file tree acc ->\n match C.Tree.kind tree with\n | `Value -> (\n match List.rev file with\n | last :: _ when Compare.String.(last = len_name) -> Lwt.return acc\n | last :: rest when Compare.String.(last = data_name) -> (\n let file = List.rev rest in\n match I.of_path file with\n | None -> assert false\n | Some path -> f path acc)\n | _ -> assert false)\n | `Tree -> Lwt.return acc)\n\n let keys_unaccounted s =\n fold_keys_unaccounted s ~order:`Sorted ~init:[] ~f:(fun p acc ->\n Lwt.return (p :: acc))\n\n let () =\n let open Storage_description in\n let unpack = unpack I.args in\n register_value (* TODO export consumed gas ?? *)\n ~get:(fun c ->\n let c, k = unpack c in\n find c k >|=? fun (_, v) -> v)\n (register_indexed_subcontext\n ~list:(fun c -> keys_unaccounted c >|= ok)\n C.description\n I.args)\n V.encoding\nend\n\nmodule Make_indexed_carbonated_data_storage : functor\n (C : Raw_context.T)\n (I : INDEX)\n (V : VALUE)\n ->\n Indexed_carbonated_data_storage\n with type t = C.t\n and type key = I.t\n and type value = V.t =\n Make_indexed_carbonated_data_storage_INTERNAL\n\nmodule Make_carbonated_data_set_storage (C : Raw_context.T) (I : INDEX) :\n Carbonated_data_set_storage with type t = C.t and type elt = I.t = struct\n module V = struct\n type t = unit\n\n let encoding = Data_encoding.unit\n end\n\n module M = Make_indexed_carbonated_data_storage_INTERNAL (C) (I) (V)\n\n type t = M.t\n\n type context = t\n\n type elt = I.t\n\n let mem = M.mem\n\n let init s i = M.init s i ()\n\n let add s i = M.add s i ()\n\n let remove s i = M.remove s i\n\n let fold_keys_unaccounted = M.fold_keys_unaccounted\nend\n\nmodule Make_indexed_data_snapshotable_storage\n (C : Raw_context.T)\n (Snapshot_index : INDEX)\n (I : INDEX)\n (V : VALUE) :\n Indexed_data_snapshotable_storage\n with type t = C.t\n and type snapshot = Snapshot_index.t\n and type key = I.t\n and type value = V.t = struct\n type snapshot = Snapshot_index.t\n\n let data_name = [\"current\"]\n\n let snapshot_name = [\"snapshot\"]\n\n module C_data =\n Make_subcontext (Registered) (C)\n (struct\n let name = data_name\n end)\n\n module C_snapshot =\n Make_subcontext (Registered) (C)\n (struct\n let name = snapshot_name\n end)\n\n module V_encoder = Make_encoder (V)\n include Make_indexed_data_storage (C_data) (I) (V)\n module Snapshot =\n Make_indexed_data_storage (C_snapshot) (Pair (Snapshot_index) (I)) (V)\n\n let snapshot_path id = snapshot_name @ Snapshot_index.to_path id []\n\n let snapshot_exists s id = C.mem_tree s (snapshot_path id)\n\n let err_missing_key key = Raw_context.storage_error (Missing_key (key, Copy))\n\n let snapshot s id =\n C.find_tree s data_name >>= function\n | None -> Lwt.return (err_missing_key data_name)\n | Some tree ->\n C.add_tree s (snapshot_path id) tree >|= (fun t -> C.project t) >|= ok\n\n let fold_snapshot s id ~order ~init ~f =\n C.find_tree s (snapshot_path id) >>= function\n | None -> Lwt.return (err_missing_key data_name)\n | Some tree ->\n C_data.Tree.fold\n tree\n ~depth:(`Eq I.path_length)\n []\n ~order\n ~init:(Ok init)\n ~f:(fun file tree acc ->\n acc >>?= fun acc ->\n C.Tree.to_value tree >>= function\n | Some v -> (\n match I.of_path file with\n | None -> assert false\n | Some path -> (\n let key () = C.absolute_key s file in\n match V_encoder.of_bytes ~key v with\n | Ok v -> f path v acc\n | Error _ -> return acc))\n | None -> return acc)\n\n let delete_snapshot s id =\n C.remove s (snapshot_path id) >|= fun t -> C.project t\nend\n\nmodule Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) :\n Indexed_raw_context\n with type t = C.t\n and type key = I.t\n and type 'a ipath = 'a I.ipath\n and type local_context = C.local_context = struct\n type t = C.t\n\n type context = t\n\n type key = I.t\n\n type 'a ipath = 'a I.ipath\n\n type local_context = C.local_context\n\n let clear t = C.remove t [] >|= fun t -> C.project t\n\n let is_empty i =\n let open Lwt_syntax in\n let* root = C.find_tree i [] in\n match root with\n | None -> return_true\n | Some root -> return @@ C.Tree.is_empty root\n\n let fold_keys t ~order ~init ~f =\n C.fold ~depth:(`Eq I.path_length) t [] ~order ~init ~f:(fun path tree acc ->\n match C.Tree.kind tree with\n | `Tree -> (\n match I.of_path path with\n | None -> assert false\n | Some path -> f path acc)\n | `Value -> Lwt.return acc)\n\n let keys t =\n fold_keys t ~order:`Sorted ~init:[] ~f:(fun i acc -> Lwt.return (i :: acc))\n\n let err_missing_key key = Raw_context.storage_error (Missing_key (key, Copy))\n\n let copy t ~from ~to_ =\n let from = I.to_path from [] in\n let to_ = I.to_path to_ [] in\n C.find_tree t from >>= function\n | None -> Lwt.return (err_missing_key from)\n | Some tree -> C.add_tree t to_ tree >|= ok\n\n let remove t k = C.remove t (I.to_path k [])\n\n let description =\n Storage_description.register_indexed_subcontext\n ~list:(fun c -> keys c >|= ok)\n C.description\n I.args\n\n let unpack = Storage_description.unpack I.args\n\n let pack = Storage_description.pack I.args\n\n module Raw_context :\n Raw_context.T\n with type t = C.t I.ipath\n and type local_context = C.local_context = struct\n type t = C.t I.ipath\n\n type local_context = C.local_context\n\n let to_key i k = I.to_path i k\n\n let mem c k =\n let t, i = unpack c in\n C.mem t (to_key i k)\n\n let mem_tree c k =\n let t, i = unpack c in\n C.mem_tree t (to_key i k)\n\n let get c k =\n let t, i = unpack c in\n C.get t (to_key i k)\n\n let get_tree c k =\n let t, i = unpack c in\n C.get_tree t (to_key i k)\n\n let find c k =\n let t, i = unpack c in\n C.find t (to_key i k)\n\n let find_tree c k =\n let t, i = unpack c in\n C.find_tree t (to_key i k)\n\n let list c ?offset ?length k =\n let t, i = unpack c in\n C.list t ?offset ?length (to_key i k)\n\n let init c k v =\n let t, i = unpack c in\n C.init t (to_key i k) v >|=? fun t -> pack t i\n\n let init_tree c k v =\n let t, i = unpack c in\n C.init_tree t (to_key i k) v >|=? fun t -> pack t i\n\n let update c k v =\n let t, i = unpack c in\n C.update t (to_key i k) v >|=? fun t -> pack t i\n\n let update_tree c k v =\n let t, i = unpack c in\n C.update_tree t (to_key i k) v >|=? fun t -> pack t i\n\n let add c k v =\n let t, i = unpack c in\n C.add t (to_key i k) v >|= fun t -> pack t i\n\n let add_tree c k v =\n let t, i = unpack c in\n C.add_tree t (to_key i k) v >|= fun t -> pack t i\n\n let add_or_remove c k v =\n let t, i = unpack c in\n C.add_or_remove t (to_key i k) v >|= fun t -> pack t i\n\n let add_or_remove_tree c k v =\n let t, i = unpack c in\n C.add_or_remove_tree t (to_key i k) v >|= fun t -> pack t i\n\n let remove_existing c k =\n let t, i = unpack c in\n C.remove_existing t (to_key i k) >|=? fun t -> pack t i\n\n let remove_existing_tree c k =\n let t, i = unpack c in\n C.remove_existing_tree t (to_key i k) >|=? fun t -> pack t i\n\n let remove c k =\n let t, i = unpack c in\n C.remove t (to_key i k) >|= fun t -> pack t i\n\n let fold ?depth c k ~order ~init ~f =\n let t, i = unpack c in\n C.fold ?depth t (to_key i k) ~order ~init ~f\n\n let config c =\n let t, _ = unpack c in\n C.config t\n\n module Tree = struct\n include C.Tree\n\n let empty c =\n let t, _ = unpack c in\n C.Tree.empty t\n end\n\n module Proof = C.Proof\n\n let verify_tree_proof = C.verify_tree_proof\n\n let verify_stream_proof = C.verify_stream_proof\n\n let equal_config = C.equal_config\n\n let project c =\n let t, _ = unpack c in\n C.project t\n\n let absolute_key c k =\n let t, i = unpack c in\n C.absolute_key t (to_key i k)\n\n type error += Block_quota_exceeded = C.Block_quota_exceeded\n\n type error += Operation_quota_exceeded = C.Operation_quota_exceeded\n\n let consume_gas c g =\n let t, i = unpack c in\n C.consume_gas t g >>? fun t -> ok (pack t i)\n\n let check_enough_gas c g =\n let t, _i = unpack c in\n C.check_enough_gas t g\n\n let description = description\n\n let length c =\n let t, _i = unpack c in\n C.length t\n\n let with_local_context c k f =\n let t, i = unpack c in\n C.with_local_context t (to_key i k) f >|=? fun (t, res) -> (pack t i, res)\n\n module Local_context = C.Local_context\n end\n\n let with_local_context s i f =\n Raw_context.with_local_context (pack s i) [] f >|=? fun (c, x) ->\n let s, _ = unpack c in\n (s, x)\n\n module Make_set (R : REGISTER) (N : NAME) :\n Data_set_storage with type t = t and type elt = key = struct\n type t = C.t\n\n type context = t\n\n type elt = I.t\n\n let inited = Bytes.of_string \"inited\"\n\n let mem s i = Raw_context.mem (pack s i) N.name\n\n let add s i =\n Raw_context.add (pack s i) N.name inited >|= fun c ->\n let s, _ = unpack c in\n C.project s\n\n let remove s i =\n Raw_context.remove (pack s i) N.name >|= fun c ->\n let s, _ = unpack c in\n C.project s\n\n let clear s =\n fold_keys s ~init:s ~order:`Sorted ~f:(fun i s ->\n Raw_context.remove (pack s i) N.name >|= fun c ->\n let s, _ = unpack c in\n s)\n >|= fun t -> C.project t\n\n let fold s ~order ~init ~f =\n fold_keys s ~order ~init ~f:(fun i acc ->\n mem s i >>= function true -> f i acc | false -> Lwt.return acc)\n\n let elements s =\n fold s ~order:`Sorted ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))\n\n let () =\n let open Storage_description in\n let unpack = unpack I.args in\n let description =\n if R.ghost then Storage_description.create ()\n else Raw_context.description\n in\n register_value\n ~get:(fun c ->\n let c, k = unpack c in\n mem c k >>= function true -> return_some true | false -> return_none)\n (register_named_subcontext description N.name)\n Data_encoding.bool\n end\n\n module Make_map (R : REGISTER) (N : NAME) (V : VALUE) :\n Indexed_data_storage_with_local_context\n with type t = t\n and type key = key\n and type value = V.t\n and type local_context = local_context = struct\n type t = C.t\n\n type context = t\n\n type key = I.t\n\n type value = V.t\n\n type nonrec local_context = local_context\n\n include Make_encoder (V)\n\n let is_empty i =\n let open Lwt_syntax in\n let* root = C.find_tree i [] in\n match root with\n | None -> return_true\n | Some root -> return @@ C.Tree.is_empty root\n\n let mem s i = Raw_context.mem (pack s i) N.name\n\n let get s i =\n Raw_context.get (pack s i) N.name >>=? fun b ->\n let key () = Raw_context.absolute_key (pack s i) N.name in\n Lwt.return (of_bytes ~key b)\n\n let find s i =\n Raw_context.find (pack s i) N.name >|= function\n | None -> Result.return_none\n | Some b ->\n let key () = Raw_context.absolute_key (pack s i) N.name in\n of_bytes ~key b >|? fun v -> Some v\n\n let update s i v =\n Raw_context.update (pack s i) N.name (to_bytes v) >|=? fun c ->\n let s, _ = unpack c in\n C.project s\n\n let init s i v =\n Raw_context.init (pack s i) N.name (to_bytes v) >|=? fun c ->\n let s, _ = unpack c in\n C.project s\n\n let add s i v =\n Raw_context.add (pack s i) N.name (to_bytes v) >|= fun c ->\n let s, _ = unpack c in\n C.project s\n\n let add_or_remove s i v =\n Raw_context.add_or_remove (pack s i) N.name (Option.map to_bytes v)\n >|= fun c ->\n let s, _ = unpack c in\n C.project s\n\n let remove s i =\n Raw_context.remove (pack s i) N.name >|= fun c ->\n let s, _ = unpack c in\n C.project s\n\n let remove_existing s i =\n Raw_context.remove_existing (pack s i) N.name >|=? fun c ->\n let s, _ = unpack c in\n C.project s\n\n let clear s =\n fold_keys s ~order:`Sorted ~init:s ~f:(fun i s ->\n Raw_context.remove (pack s i) N.name >|= fun c ->\n let s, _ = unpack c in\n s)\n >|= fun t -> C.project t\n\n let fold s ~order ~init ~f =\n fold_keys s ~order ~init ~f:(fun i acc ->\n get s i >>= function Error _ -> Lwt.return acc | Ok v -> f i v acc)\n\n let bindings s =\n fold s ~order:`Sorted ~init:[] ~f:(fun p v acc ->\n Lwt.return ((p, v) :: acc))\n\n let fold_keys s ~order ~init ~f =\n fold_keys s ~order ~init ~f:(fun i acc ->\n mem s i >>= function false -> Lwt.return acc | true -> f i acc)\n\n let keys s =\n fold_keys s ~order:`Sorted ~init:[] ~f:(fun p acc ->\n Lwt.return (p :: acc))\n\n let () =\n let open Storage_description in\n let unpack = unpack I.args in\n let description =\n if R.ghost then Storage_description.create ()\n else Raw_context.description\n in\n register_value\n ~get:(fun c ->\n let c, k = unpack c in\n find c k)\n (register_named_subcontext description N.name)\n V.encoding\n\n module Local = struct\n type context = Raw_context.Local_context.t\n\n let mem local = Raw_context.Local_context.mem local N.name\n\n let get local =\n Raw_context.Local_context.get local N.name >|= fun r ->\n let key () = Raw_context.Local_context.absolute_key local N.name in\n r >>? of_bytes ~key\n\n let find local =\n Raw_context.Local_context.find local N.name >|= function\n | None -> Result.return_none\n | Some b ->\n let key () = Raw_context.Local_context.absolute_key local N.name in\n of_bytes ~key b >|? fun v -> Some v\n\n let init local v =\n Raw_context.Local_context.init local N.name (to_bytes v)\n\n let update local v =\n Raw_context.Local_context.update local N.name (to_bytes v)\n\n let add local v = Raw_context.Local_context.add local N.name (to_bytes v)\n\n let add_or_remove local vo =\n Raw_context.Local_context.add_or_remove\n local\n N.name\n (Option.map to_bytes vo)\n\n let remove_existing local =\n Raw_context.Local_context.remove_existing local N.name\n\n let remove local = Raw_context.Local_context.remove local N.name\n end\n end\n\n module Make_carbonated_map (R : REGISTER) (N : NAME) (V : VALUE) :\n Non_iterable_indexed_carbonated_data_storage\n with type t = t\n and type key = key\n and type value = V.t = struct\n type t = C.t\n\n type context = t\n\n type key = I.t\n\n type value = V.t\n\n include Make_encoder (V)\n\n let len_name = len_name :: N.name\n\n let data_name = data_name :: N.name\n\n let consume_mem_gas c =\n let path_length = List.length (Raw_context.absolute_key c N.name) + 1 in\n Raw_context.consume_gas\n c\n (Storage_costs.read_access ~path_length ~read_bytes:0)\n\n let existing_size c =\n Raw_context.find c len_name >|= function\n | None -> ok (0, false)\n | Some len -> decode_len_value len_name len >|? fun len -> (len, true)\n\n let consume_read_gas get c =\n let path_length = List.length (Raw_context.absolute_key c N.name) + 1 in\n get c len_name >>=? fun len ->\n Lwt.return\n ( decode_len_value len_name len >>? fun read_bytes ->\n Raw_context.consume_gas\n c\n (Storage_costs.read_access ~path_length ~read_bytes) )\n\n let consume_write_gas set c v =\n let bytes = to_bytes v in\n let len = Bytes.length bytes in\n Raw_context.consume_gas c (Storage_costs.write_access ~written_bytes:len)\n >>?= fun c ->\n set c len_name (encode_len_value bytes) >|=? fun c -> (c, bytes)\n\n let consume_remove_gas del c =\n Raw_context.consume_gas c (Storage_costs.write_access ~written_bytes:0)\n >>?= fun c -> del c len_name\n\n let mem s i =\n consume_mem_gas (pack s i) >>?= fun c ->\n Raw_context.mem c data_name >|= fun res -> ok (Raw_context.project c, res)\n\n let get s i =\n consume_read_gas Raw_context.get (pack s i) >>=? fun c ->\n Raw_context.get c data_name >>=? fun b ->\n let key () = Raw_context.absolute_key c data_name in\n Lwt.return (of_bytes ~key b >|? fun v -> (Raw_context.project c, v))\n\n let find s i =\n consume_mem_gas (pack s i) >>?= fun c ->\n let s, _ = unpack c in\n Raw_context.mem (pack s i) data_name >>= fun exists ->\n if exists then get s i >|=? fun (s, v) -> (s, Some v)\n else return (C.project s, None)\n\n let update s i v =\n existing_size (pack s i) >>=? fun (prev_size, _) ->\n consume_write_gas Raw_context.update (pack s i) v >>=? fun (c, bytes) ->\n Raw_context.update c data_name bytes >|=? fun c ->\n let size_diff = Bytes.length bytes - prev_size in\n (Raw_context.project c, size_diff)\n\n let init s i v =\n consume_write_gas Raw_context.init (pack s i) v >>=? fun (c, bytes) ->\n Raw_context.init c data_name bytes >|=? fun c ->\n let size = Bytes.length bytes in\n (Raw_context.project c, size)\n\n let add s i v =\n let add c k v = Raw_context.add c k v >|= ok in\n existing_size (pack s i) >>=? fun (prev_size, existed) ->\n consume_write_gas add (pack s i) v >>=? fun (c, bytes) ->\n add c data_name bytes >|=? fun c ->\n let size_diff = Bytes.length bytes - prev_size in\n (Raw_context.project c, size_diff, existed)\n\n let remove s i =\n let remove c k = Raw_context.remove c k >|= ok in\n existing_size (pack s i) >>=? fun (prev_size, existed) ->\n consume_remove_gas remove (pack s i) >>=? fun c ->\n remove c data_name >|=? fun c ->\n (Raw_context.project c, prev_size, existed)\n\n let remove_existing s i =\n existing_size (pack s i) >>=? fun (prev_size, _) ->\n consume_remove_gas Raw_context.remove_existing (pack s i) >>=? fun c ->\n Raw_context.remove_existing c data_name >|=? fun c ->\n (Raw_context.project c, prev_size)\n\n let add_or_remove s i v =\n match v with None -> remove s i | Some v -> add s i v\n\n let mem_unaccounted s i = Raw_context.mem (pack s i) data_name\n\n let fold_keys_unaccounted s ~order ~init ~f =\n fold_keys s ~order ~init ~f:(fun i acc ->\n mem_unaccounted s i >>= function\n | false -> Lwt.return acc\n | true -> f i acc)\n\n let keys_unaccounted s =\n fold_keys_unaccounted s ~order:`Sorted ~init:[] ~f:(fun p acc ->\n Lwt.return (p :: acc))\n\n let () =\n let open Storage_description in\n let unpack = unpack I.args in\n let description =\n if R.ghost then Storage_description.create ()\n else Raw_context.description\n in\n register_value\n ~get:(fun c ->\n let c, k = unpack c in\n find c k >|=? fun (_, v) -> v)\n (register_named_subcontext description N.name)\n V.encoding\n end\nend\n\nmodule type WRAPPER = sig\n type t\n\n type key\n\n val wrap : t -> key\n\n val unwrap : key -> t option\nend\n\nmodule Wrap_indexed_data_storage\n (C : Indexed_data_storage)\n (K : WRAPPER with type key := C.key) :\n Indexed_data_storage\n with type t = C.t\n and type key = K.t\n and type value = C.value = struct\n type t = C.t\n\n type context = C.t\n\n type key = K.t\n\n type value = C.value\n\n let is_empty ctxt = C.is_empty ctxt\n\n let mem ctxt k = C.mem ctxt (K.wrap k)\n\n let get ctxt k = C.get ctxt (K.wrap k)\n\n let find ctxt k = C.find ctxt (K.wrap k)\n\n let update ctxt k v = C.update ctxt (K.wrap k) v\n\n let init ctxt k v = C.init ctxt (K.wrap k) v\n\n let add ctxt k v = C.add ctxt (K.wrap k) v\n\n let add_or_remove ctxt k v = C.add_or_remove ctxt (K.wrap k) v\n\n let remove_existing ctxt k = C.remove_existing ctxt (K.wrap k)\n\n let remove ctxt k = C.remove ctxt (K.wrap k)\n\n let clear ctxt = C.clear ctxt\n\n let fold ctxt ~order ~init ~f =\n C.fold ctxt ~order ~init ~f:(fun k v acc ->\n match K.unwrap k with None -> Lwt.return acc | Some k -> f k v acc)\n\n let bindings s =\n fold s ~order:`Sorted ~init:[] ~f:(fun p v acc ->\n Lwt.return ((p, v) :: acc))\n\n let fold_keys s ~order ~init ~f =\n C.fold_keys s ~order ~init ~f:(fun k acc ->\n match K.unwrap k with None -> Lwt.return acc | Some k -> f k acc)\n\n let keys s =\n fold_keys s ~order:`Sorted ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))\nend\n" ;
} ;
{ name = "Storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Tezos Protocol Implementation - Typed storage\n\n This module hides the hierarchical (key x value) database under\n pre-allocated typed accessors for all persistent entities of the\n tezos context.\n\n This interface enforces no invariant on the contents of the\n database. Its goal is to centralize all accessors in order to have\n a complete view over the database contents and avoid key\n collisions. *)\n\nopen Storage_sigs\n\nmodule type Simple_single_data_storage = sig\n type value\n\n val get : Raw_context.t -> value tzresult Lwt.t\n\n val update : Raw_context.t -> value -> Raw_context.t tzresult Lwt.t\n\n val init : Raw_context.t -> value -> Raw_context.t tzresult Lwt.t\nend\n\nmodule Block_round : Simple_single_data_storage with type value = Round_repr.t\n\ntype deposits = {initial_amount : Tez_repr.t; current_amount : Tez_repr.t}\n\ntype missed_endorsements_info = {remaining_slots : int; missed_levels : int}\n\nmodule Contract : sig\n (** Storage from this submodule must only be accessed through the\n module `Contract`. *)\n\n module Global_counter :\n Simple_single_data_storage with type value = Manager_counter_repr.t\n\n (** The domain of alive contracts *)\n val fold :\n Raw_context.t ->\n order:[`Sorted | `Undefined] ->\n init:'a ->\n f:(Contract_repr.t -> 'a -> 'a Lwt.t) ->\n 'a Lwt.t\n\n val list : Raw_context.t -> Contract_repr.t list Lwt.t\n\n (** see {!Raw_context_intf.T.local_context} *)\n type local_context\n\n (** see {!Raw_context_intf.T.with_local_context} *)\n val with_local_context :\n Raw_context.t ->\n Contract_repr.t ->\n (local_context -> (local_context * 'a) tzresult Lwt.t) ->\n (Raw_context.t * 'a) tzresult Lwt.t\n\n (** The tez possessed by a contract and that can be used. A contract\n may also possess tez in frozen deposits. Empty balances (of zero\n tez) are only allowed for originated contracts, not for implicit\n ones. *)\n module Spendable_balance :\n Indexed_data_storage_with_local_context\n with type key = Contract_repr.t\n and type value = Tez_repr.t\n and type t := Raw_context.t\n and type local_context := local_context\n\n (** If the value is not set, the delegate didn't miss any endorsing\n opportunity. If it is set, this value is a record of type\n [missed_endorsements_info], where:\n - [remaining_slots] is the difference between the maximum number of\n slots that can be missed and the number of missed slots;\n therefore, when the number is positive, it represents the number\n of slots that a delegate can still miss before forfeiting its\n endorsing rewards for the current cycle; when the number is zero\n it means rewards are not lost, but no further slots can be\n missed anymore;\n - [missed_levels] represents the number of missed levels (for\n endorsing). *)\n module Missed_endorsements :\n Indexed_data_storage\n with type key = Contract_repr.t\n and type value = missed_endorsements_info\n and type t := Raw_context.t\n\n (** The manager of a contract *)\n module Manager :\n Indexed_data_storage_with_local_context\n with type key = Contract_repr.t\n and type value = Manager_repr.t\n and type t := Raw_context.t\n and type local_context := local_context\n\n (** The active consensus key of a delegate *)\n module Consensus_key :\n Indexed_data_storage\n with type key = Contract_repr.t\n and type value = Signature.Public_key.t\n and type t := Raw_context.t\n\n (** The pending consensus key of a delegate *)\n module Pending_consensus_keys :\n Indexed_data_storage\n with type key = Cycle_repr.t\n and type value = Signature.Public_key.t\n and type t := Raw_context.t * Contract_repr.t\n\n (** The delegate of a contract, if any. *)\n module Delegate :\n Indexed_data_storage\n with type key = Contract_repr.t\n and type value = Signature.Public_key_hash.t\n and type t := Raw_context.t\n\n (** All contracts (implicit and originated) that are delegated, if any *)\n module Delegated :\n Data_set_storage\n with type elt = Contract_repr.t\n and type t = Raw_context.t * Contract_repr.t\n\n (** The part of a delegate balance that can't be used. The total\n balance is frozen_deposits.current_amount + balance. It also stores\n the initial frozen balance in frozen_deposits.initial_amount. We\n have current_amount <= initial_amount and current_amount <\n initial_amount iff the delegate was slashed. *)\n module Frozen_deposits :\n Indexed_data_storage\n with type key = Contract_repr.t\n and type value = deposits\n and type t := Raw_context.t\n\n (** If there is a value, the frozen balance for the contract won't\n exceed it (starting in preserved_cycles + 1). *)\n module Frozen_deposits_limit :\n Indexed_data_storage\n with type key = Contract_repr.t\n and type value = Tez_repr.t\n and type t := Raw_context.t\n\n module Inactive_delegate :\n Data_set_storage with type elt = Contract_repr.t and type t = Raw_context.t\n\n (** The last cycle where the delegate is considered active; that is,\n at the next cycle it will be considered inactive. *)\n module Delegate_last_cycle_before_deactivation :\n Indexed_data_storage\n with type key = Contract_repr.t\n and type value = Cycle_repr.t\n and type t := Raw_context.t\n\n module Counter :\n Indexed_data_storage_with_local_context\n with type key = Contract_repr.t\n and type value = Manager_counter_repr.t\n and type t := Raw_context.t\n and type local_context := local_context\n\n module Code :\n Non_iterable_indexed_carbonated_data_storage\n with type key = Contract_repr.t\n and type value = Script_repr.lazy_expr\n and type t := Raw_context.t\n\n module Storage :\n Non_iterable_indexed_carbonated_data_storage\n with type key = Contract_repr.t\n and type value = Script_repr.lazy_expr\n and type t := Raw_context.t\n\n (** Current storage space in bytes.\n Includes code, global storage and big map elements. *)\n module Used_storage_space :\n Indexed_data_storage\n with type key = Contract_repr.t\n and type value = Z.t\n and type t := Raw_context.t\n\n (** Maximal space available without needing to burn new fees. *)\n module Paid_storage_space :\n Indexed_data_storage\n with type key = Contract_repr.t\n and type value = Z.t\n and type t := Raw_context.t\n\n (** Associates a contract and a bond_id with a bond, i.e. an amount of tez\n that is frozen. *)\n module Frozen_bonds :\n Non_iterable_indexed_carbonated_data_storage\n with type key = Bond_id_repr.t\n and type value = Tez_repr.t\n and type t := Raw_context.t * Contract_repr.t\n\n val fold_bond_ids :\n Raw_context.t * Contract_repr.t ->\n order:[`Sorted | `Undefined] ->\n init:'a ->\n f:(Bond_id_repr.t -> 'a -> 'a Lwt.t) ->\n 'a Lwt.t\n\n (** Associates a contract with the total of all its frozen bonds. *)\n module Total_frozen_bonds :\n Indexed_data_storage\n with type key = Contract_repr.t\n and type value = Tez_repr.t\n and type t := Raw_context.t\nend\n\nmodule Big_map : sig\n type id = Lazy_storage_kind.Big_map.Id.t\n\n module Next : sig\n val incr : Raw_context.t -> (Raw_context.t * id) tzresult Lwt.t\n\n val init : Raw_context.t -> Raw_context.t tzresult Lwt.t\n end\n\n (** The domain of alive big maps *)\n val fold :\n Raw_context.t ->\n order:[`Sorted | `Undefined] ->\n init:'a ->\n f:(id -> 'a -> 'a Lwt.t) ->\n 'a Lwt.t\n\n val list : Raw_context.t -> id list Lwt.t\n\n val remove : Raw_context.t -> id -> Raw_context.t Lwt.t\n\n val copy : Raw_context.t -> from:id -> to_:id -> Raw_context.t tzresult Lwt.t\n\n type key = Raw_context.t * id\n\n val rpc_arg : id RPC_arg.t\n\n module Contents : sig\n include\n Non_iterable_indexed_carbonated_data_storage\n with type key = Script_expr_hash.t\n and type value = Script_repr.expr\n and type t := key\n\n val list_key_values :\n ?offset:int ->\n ?length:int ->\n Raw_context.t * id ->\n (Raw_context.t * (Script_expr_hash.t * Script_repr.expr) list) tzresult\n Lwt.t\n end\n\n module Total_bytes :\n Indexed_data_storage_with_local_context\n with type key = id\n and type value = Z.t\n and type t := Raw_context.t\n\n module Key_type :\n Indexed_data_storage\n with type key = id\n and type value = Script_repr.expr\n and type t := Raw_context.t\n\n module Value_type :\n Indexed_data_storage\n with type key = id\n and type value = Script_repr.expr\n and type t := Raw_context.t\nend\n\nmodule Sapling : sig\n type id = Lazy_storage_kind.Sapling_state.Id.t\n\n val rpc_arg : id RPC_arg.t\n\n module Next : sig\n val incr : Raw_context.t -> (Raw_context.t * id) tzresult Lwt.t\n\n val init : Raw_context.t -> Raw_context.t tzresult Lwt.t\n end\n\n val copy : Raw_context.t -> from:id -> to_:id -> Raw_context.t tzresult Lwt.t\n\n val remove : Raw_context.t -> id -> Raw_context.t Lwt.t\n\n module Total_bytes :\n Indexed_data_storage\n with type key = id\n and type value = Z.t\n and type t := Raw_context.t\n\n (* Used by both Commitments and Ciphertexts *)\n module Commitments_size :\n Single_data_storage with type t := Raw_context.t * id and type value = int64\n\n module Memo_size :\n Single_data_storage with type t := Raw_context.t * id and type value = int\n\n module Commitments :\n Non_iterable_indexed_carbonated_data_storage\n with type t := Raw_context.t * id\n and type key = int64\n and type value = Sapling.Hash.t\n\n val commitments_init : Raw_context.t -> id -> Raw_context.t Lwt.t\n\n module Ciphertexts :\n Non_iterable_indexed_carbonated_data_storage\n with type t := Raw_context.t * id\n and type key = int64\n and type value = Sapling.Ciphertext.t\n\n val ciphertexts_init : Raw_context.t -> id -> Raw_context.t Lwt.t\n\n module Nullifiers_size :\n Single_data_storage with type t := Raw_context.t * id and type value = int64\n\n module Nullifiers_ordered :\n Non_iterable_indexed_data_storage\n with type t := Raw_context.t * id\n and type key = int64\n and type value = Sapling.Nullifier.t\n\n module Nullifiers_hashed :\n Carbonated_data_set_storage\n with type t := Raw_context.t * id\n and type elt = Sapling.Nullifier.t\n\n val nullifiers_init : Raw_context.t -> id -> Raw_context.t Lwt.t\n\n module Roots :\n Non_iterable_indexed_data_storage\n with type t := Raw_context.t * id\n and type key = int32\n and type value = Sapling.Hash.t\n\n module Roots_pos :\n Single_data_storage with type t := Raw_context.t * id and type value = int32\n\n module Roots_level :\n Single_data_storage\n with type t := Raw_context.t * id\n and type value = Raw_level_repr.t\nend\n\n(** Set of all registered delegates. *)\nmodule Delegates :\n Data_set_storage\n with type t := Raw_context.t\n and type elt = Signature.Public_key_hash.t\n\n(** Set of all active consensus keys in cycle `current + preserved_cycles + 1` *)\nmodule Consensus_keys :\n Data_set_storage\n with type t := Raw_context.t\n and type elt = Signature.Public_key_hash.t\n\ntype slashed_level = {for_double_endorsing : bool; for_double_baking : bool}\n\n(** Set used to avoid slashing multiple times the same event *)\nmodule Slashed_deposits :\n Indexed_data_storage\n with type t := Raw_context.t * Cycle_repr.t\n and type key = Raw_level_repr.t * Signature.Public_key_hash.t\n and type value = slashed_level\n\nmodule Stake : sig\n (** The map of all the staking balances of all delegates, including\n those with less than\n {!Constants_parametric_repr.minimal_stake}. It might be large *)\n module Staking_balance :\n Indexed_data_snapshotable_storage\n with type key = Signature.Public_key_hash.t\n and type value = Tez_repr.t\n and type snapshot = int\n and type t := Raw_context.t\n\n (** This is a set, encoded in a map with value unit. This should be\n fairly small compared to staking balance *)\n module Active_delegates_with_minimal_stake :\n Indexed_data_snapshotable_storage\n with type key = Signature.Public_key_hash.t\n and type value = unit\n and type snapshot = int\n and type t := Raw_context.t\n\n (** Counter of stake storage snapshots taken since last cycle *)\n module Last_snapshot :\n Single_data_storage with type value = int and type t := Raw_context.t\n\n (** List of active stake *)\n module Selected_distribution_for_cycle :\n Indexed_data_storage\n with type key = Cycle_repr.t\n and type value = (Signature.Public_key_hash.t * Tez_repr.t) list\n and type t := Raw_context.t\n\n (** Sum of the active stakes of all the delegates with\n {!Constants_parametric_repr.minimal_stake} *)\n module Total_active_stake :\n Indexed_data_storage\n with type key = Cycle_repr.t\n and type value = Tez_repr.t\n and type t := Raw_context.t\nend\n\n(** State of the sampler used to select delegates. Managed synchronously\n with [Stake.Selected_distribution_for_cycle]. *)\nmodule Delegate_sampler_state :\n Indexed_data_storage\n with type key = Cycle_repr.t\n and type value = Raw_context.consensus_pk Sampler.t\n and type t := Raw_context.t\n\n(** Votes *)\n\nmodule Vote : sig\n module Pred_period_kind :\n Single_data_storage\n with type value = Voting_period_repr.kind\n and type t := Raw_context.t\n\n module Current_period :\n Single_data_storage\n with type value = Voting_period_repr.t\n and type t := Raw_context.t\n\n (** Participation exponential moving average, in centile of percentage *)\n module Participation_ema :\n Single_data_storage with type value = int32 and type t := Raw_context.t\n\n module Current_proposal :\n Single_data_storage\n with type value = Protocol_hash.t\n and type t := Raw_context.t\n\n (** Sum of voting weights of all delegates. *)\n module Voting_power_in_listings :\n Single_data_storage with type value = int64 and type t := Raw_context.t\n\n (** Contains all delegates with their assigned voting weight. *)\n module Listings :\n Indexed_data_storage\n with type key = Signature.Public_key_hash.t\n and type value = int64\n and type t := Raw_context.t\n\n (** Set of protocol proposal with corresponding proposer delegate *)\n module Proposals :\n Data_set_storage\n with type elt = Protocol_hash.t * Signature.Public_key_hash.t\n and type t := Raw_context.t\n\n (** Keeps for each delegate the number of proposed protocols *)\n module Proposals_count :\n Indexed_data_storage\n with type key = Signature.Public_key_hash.t\n and type value = int\n and type t := Raw_context.t\n\n (** Contains for each delegate its ballot *)\n module Ballots :\n Indexed_data_storage\n with type key = Signature.Public_key_hash.t\n and type value = Vote_repr.ballot\n and type t := Raw_context.t\nend\n\nmodule type FOR_CYCLE = sig\n val init :\n Raw_context.t ->\n Cycle_repr.t ->\n Seed_repr.seed ->\n Raw_context.t tzresult Lwt.t\n\n val mem : Raw_context.t -> Cycle_repr.t -> bool Lwt.t\n\n val get : Raw_context.t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t\n\n val update :\n Raw_context.t ->\n Cycle_repr.t ->\n Seed_repr.seed ->\n Seed_repr.seed_status ->\n Raw_context.t tzresult Lwt.t\n\n val remove_existing :\n Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t\nend\n\n(** Seed *)\n\nmodule Seed_status :\n Simple_single_data_storage with type value = Seed_repr.seed_status\n\nmodule Seed : sig\n (** Storage from this submodule must only be accessed through the\n module `Seed`. *)\n\n type unrevealed_nonce = {\n nonce_hash : Nonce_hash.t;\n delegate : Signature.Public_key_hash.t;\n }\n\n type nonce_status =\n | Unrevealed of unrevealed_nonce\n | Revealed of Seed_repr.nonce\n\n module Nonce :\n Non_iterable_indexed_data_storage\n with type key := Level_repr.t\n and type value := nonce_status\n and type t := Raw_context.t\n\n module VDF_setup :\n Single_data_storage\n with type value = Seed_repr.vdf_setup\n and type t := Raw_context.t\n\n module For_cycle : FOR_CYCLE\n\n val get_status : Raw_context.t -> Seed_repr.seed_status tzresult Lwt.t\nend\n\n(** Commitments *)\n\nmodule Commitments :\n Indexed_data_storage\n with type key = Blinded_public_key_hash.t\n and type value = Tez_repr.t\n and type t := Raw_context.t\n\n(** Ramp up rewards *)\nmodule Ramp_up : sig\n type reward = {\n baking_reward_fixed_portion : Tez_repr.t;\n baking_reward_bonus_per_slot : Tez_repr.t;\n endorsing_reward_per_slot : Tez_repr.t;\n }\n\n module Rewards :\n Indexed_data_storage\n with type key = Cycle_repr.t\n and type value := reward\n and type t := Raw_context.t\nend\n\nmodule Pending_migration : sig\n module Balance_updates :\n Single_data_storage\n with type value = Receipt_repr.balance_updates\n and type t := Raw_context.t\n\n module Operation_results :\n Single_data_storage\n with type value = Migration_repr.origination_result list\n and type t := Raw_context.t\n\n val remove :\n Raw_context.t ->\n (Raw_context.t\n * Receipt_repr.balance_updates\n * Migration_repr.origination_result list)\n tzresult\n Lwt.t\nend\n\nmodule Liquidity_baking : sig\n (** Exponential moving average (ema) of flags set in protocol_data.contents.\n The liquidity baking subsidy is not sent to the CPMM if this EMA is above\n the threshold set in constants. **)\n module Toggle_ema :\n Single_data_storage with type t := Raw_context.t and type value = Int32.t\n\n (** Constant product market maker contract that receives liquidity baking subsidy. **)\n module Cpmm_address :\n Single_data_storage\n with type t := Raw_context.t\n and type value = Contract_hash.t\nend\n\n(** A map of [Script_repr.expr] values, indexed by their hash ([Script_expr_hash.t]).\n Values from this map can be incorporated by any contract via the primitive\n [Michelson_v1_primitives.H_constant]. *)\nmodule Global_constants : sig\n module Map :\n Non_iterable_indexed_carbonated_data_storage\n with type t := Raw_context.t\n and type key = Script_expr_hash.t\n and type value = Script_repr.expr\nend\n\n(** This module exposes a balance table for tracking ticket ownership.\n The table is a mapping from keys to values where the keys consist of a\n hashed representation of:\n - A ticketer, i.e. the creator of the ticket\n - The content of a the ticket\n - The contract that owns some amount of the ticket\n The values of the table are the amounts owned by each key.\n *)\nmodule Ticket_balance : sig\n module Table :\n Non_iterable_indexed_carbonated_data_storage\n with type t := Raw_context.t\n and type key = Ticket_hash_repr.t\n and type value = Z.t\n\n module Paid_storage_space :\n Single_data_storage with type t := Raw_context.t and type value = Z.t\n\n module Used_storage_space :\n Single_data_storage with type t := Raw_context.t and type value = Z.t\nend\n\n(** Tenderbake *)\n\nmodule Tenderbake : sig\n (** [First_level_of_protocol] stores the level of the first block of\n this protocol. *)\n module First_level_of_protocol :\n Single_data_storage\n with type t := Raw_context.t\n and type value = Raw_level_repr.t\n\n (** [Endorsement_branch] stores a single value composed of the\n grandparent hash and the predecessor's payload (computed with\n the grandparent hash) used to verify the validity of\n endorsements. *)\n module Endorsement_branch :\n Single_data_storage\n with type value = Block_hash.t * Block_payload_hash.t\n and type t := Raw_context.t\n\n (** [Grand_parent_branch] stores a single value composed of the\n great-grand parent hash and the grand parent's payload *)\n module Grand_parent_branch :\n Single_data_storage\n with type value = Block_hash.t * Block_payload_hash.t\n and type t := Raw_context.t\nend\n\nmodule Tx_rollup : sig\n (** [State] stores the state of a transaction rollup. *)\n module State :\n Non_iterable_indexed_carbonated_data_storage\n with type key = Tx_rollup_repr.t\n and type value = Tx_rollup_state_repr.t\n and type t := Raw_context.t\n\n (** The representation of an inbox. See {!Tx_rollup_inbox_repr.t}\n for a description of the actual content. *)\n module Inbox :\n Non_iterable_indexed_carbonated_data_storage\n with type t := Raw_context.t * Tx_rollup_repr.t\n and type key = Tx_rollup_level_repr.t\n and type value = Tx_rollup_inbox_repr.t\n\n (** A carbonated storage of the set of withdrawals revealed of those\n potentially associated to each message of an inbox. The key is the message\n number, which is sequentially assigned from 0. *)\n module Revealed_withdrawals :\n Non_iterable_indexed_carbonated_data_storage\n with type t := Raw_context.t * Tx_rollup_repr.t\n and type key = Tx_rollup_level_repr.t\n and type value = Bitset.t\n\n (** A rollup can have at most one commitment per rollup level. Some\n metadata are saved in addition to the commitment itself. See\n {!Tx_rollup_commitment_repr.Submitted_commitment.t} for the exact\n content. *)\n module Commitment :\n Non_iterable_indexed_carbonated_data_storage\n with type key = Tx_rollup_level_repr.t\n and type value = Tx_rollup_commitment_repr.Submitted_commitment.t\n and type t := Raw_context.t * Tx_rollup_repr.t\n\n (** This stores information about which contracts have bonds\n for each rollup, and how many commitments those bonds\n stake. *)\n module Commitment_bond :\n Non_iterable_indexed_carbonated_data_storage\n with type key = Signature.public_key_hash\n and type value = int\n and type t := Raw_context.t * Tx_rollup_repr.t\nend\n\nmodule Sc_rollup : sig\n (** Smart contract rollup.\n\n Storage from this submodule must only be accessed through the\n module `Sc_rollup_storage`.\n\n Each smart contract rollup is associated to:\n\n - a PVM kind (provided at creation time, read-only)\n - a metadata (generated at creation time, read-only)\n - a boot sector (provided at creation time, read-only)\n - a parameters type specifying the types of parameters the rollup accepts\n - the L1 block level at which the rollup was created\n - a merkelized inbox, of which only the root hash is stored\n - a map from stakers to their newest staked commitments\n - a map from stakers to commitments\n - a map from commitments to the time (level) of their first insertion\n\n For performance reasons we also store (per rollup):\n\n - the total number of active stakers;\n - the number of stakers per commitment.\n - the commitments per inbox level.\n\n See module {!Sc_rollup_repr.Commitment} for details.\n *)\n module PVM_kind :\n Non_iterable_indexed_carbonated_data_storage\n with type key = Sc_rollup_repr.t\n and type value = Sc_rollups.Kind.t\n and type t := Raw_context.t\n\n module Parameters_type :\n Non_iterable_indexed_carbonated_data_storage\n with type key = Sc_rollup_repr.t\n and type value = Script_repr.lazy_expr\n and type t := Raw_context.t\n\n module Genesis_info :\n Non_iterable_indexed_carbonated_data_storage\n with type key = Sc_rollup_repr.t\n and type value = Sc_rollup_commitment_repr.genesis_info\n and type t := Raw_context.t\n\n module Inbox :\n Single_data_storage\n with type value = Sc_rollup_inbox_repr.t\n and type t := Raw_context.t\n\n module Last_cemented_commitment :\n Non_iterable_indexed_carbonated_data_storage\n with type key = Sc_rollup_repr.t\n and type value = Sc_rollup_commitment_repr.Hash.t\n and type t := Raw_context.t\n\n (** Contains the current latest attributed index for stakers. *)\n module Staker_index_counter :\n Single_data_storage\n with type value = Sc_rollup_staker_index_repr.t\n and type t = Raw_context.t * Sc_rollup_repr.t\n\n (** Contains the index of any staker that currently have stake. *)\n module Staker_index :\n Non_iterable_indexed_carbonated_data_storage\n with type key = Signature.Public_key_hash.t\n and type value = Sc_rollup_staker_index_repr.t\n and type t = Raw_context.t * Sc_rollup_repr.t\n\n (** Contains the most recent inbox level staked by an active staker. *)\n module Stakers :\n Non_iterable_indexed_carbonated_data_storage\n with type key = Sc_rollup_staker_index_repr.t\n and type value = Raw_level_repr.t\n and type t = Raw_context.t * Sc_rollup_repr.t\n\n module Commitments :\n Non_iterable_indexed_carbonated_data_storage\n with type key = Sc_rollup_commitment_repr.Hash.t\n and type value = Sc_rollup_commitment_repr.t\n and type t = Raw_context.t * Sc_rollup_repr.t\n\n (** Contains for all commitment not yet cemented the list of stakers that have\n staked on it. *)\n module Commitment_stakers :\n Non_iterable_indexed_carbonated_data_storage\n with type key = Sc_rollup_commitment_repr.Hash.t\n and type value = Sc_rollup_staker_index_repr.t list\n and type t = Raw_context.t * Sc_rollup_repr.t\n\n (** This storage contains for each rollup and inbox level not yet cemented the\n level of publication of the first commitment. This is used to compute the\n curfew for a given rollup and inbox level.\n\n The storage size is bounded for each rollup by\n\n [max_lookahead / commitment_period]\n\n Since the storage is cleaned when commitments are cemented, this storage\n space is only temporarily bought by stakers with their deposits.\n *)\n module Commitment_first_publication_level :\n Non_iterable_indexed_carbonated_data_storage\n with type key = Raw_level_repr.t\n and type value = Raw_level_repr.t\n and type t = Raw_context.t * Sc_rollup_repr.t\n\n (** Stores the commitments published for an inbox level. *)\n module Commitments_per_inbox_level :\n Non_iterable_indexed_carbonated_data_storage\n with type key = Raw_level_repr.t\n and type value = Sc_rollup_commitment_repr.Hash.t list\n and type t = Raw_context.t * Sc_rollup_repr.t\n\n module Commitment_added :\n Non_iterable_indexed_carbonated_data_storage\n with type key = Sc_rollup_commitment_repr.Hash.t\n and type value = Raw_level_repr.t\n and type t = Raw_context.t * Sc_rollup_repr.t\n\n module Game_info :\n Non_iterable_indexed_carbonated_data_storage\n with type key = Sc_rollup_game_repr.Index.t\n and type value = Sc_rollup_game_repr.t\n and type t = Raw_context.t * Sc_rollup_repr.t\n\n (** Refutation games are indexed by the rollup, by one staker, and\n by its opponent staker. Hence, each game appears twice. This is\n convenient to quickly compute the opponents of a given staker. *)\n module Game :\n Indexed_carbonated_data_storage\n with type key = Signature.Public_key_hash.t\n and type value = Sc_rollup_game_repr.Index.t\n and type t =\n (Raw_context.t * Sc_rollup_repr.t) * Signature.Public_key_hash.t\n\n (** [Game_timeout] stores the block level at which the staker whose\n turn it is to move will (become vulnerable to) timeout. The staker\n pair should always be in lexical order to ensure that this value is\n not duplicated.\n *)\n module Game_timeout :\n Non_iterable_indexed_carbonated_data_storage\n with type key = Sc_rollup_game_repr.Index.t\n and type value = Sc_rollup_game_repr.timeout\n and type t = Raw_context.t * Sc_rollup_repr.t\n\n (** A carbonated storage for keeping track of applied outbox messages for a\n a SCORU.\n\n The [key] is an [int32] value that represents the index of a SCORU's\n outbox level. An outbox level is mapped to the index through:\n\n [index = outbox_level % sc_rollup_max_active_outbox_levels]\n\n The rationale is to keep a limited number of entries. The current value of\n an entry contains the most recently added level that maps to the index.\n\n The [value] is a pair of the actual outbox level and a bitset containing\n the set of applied messages.\n *)\n module Applied_outbox_messages :\n Non_iterable_indexed_carbonated_data_storage\n with type t = Raw_context.t * Sc_rollup_repr.t\n and type key = int32\n and type value = Raw_level_repr.t * Bitset.t\nend\n\nmodule Dal : sig\n module Slot : sig\n (** This is a temporary storage for slot headers proposed onto the L1. *)\n module Headers :\n Non_iterable_indexed_data_storage\n with type t = Raw_context.t\n and type key = Raw_level_repr.t\n and type value = Dal_slot_repr.Header.t list\n\n (** This is a permanent storage for slot headers confirmed by the L1. *)\n module History :\n Single_data_storage\n with type t := Raw_context.t\n and type value = Dal_slot_repr.History.t\n end\nend\n\nmodule Zk_rollup : sig\n (** ZK rollup.\n\n Each ZK rollup is associated to:\n\n - an Account, as described in [Zk_rollup_repr]\n - a pending list description, consisting of its head's index and\n a counter\n - a map from integer indeces to L2 operations, to store the actual\n pending list\n *)\n module Account :\n Non_iterable_indexed_carbonated_data_storage\n with type t := Raw_context.t\n and type key = Zk_rollup_repr.t\n and type value = Zk_rollup_account_repr.t\n\n module Pending_list :\n Non_iterable_indexed_carbonated_data_storage\n with type t := Raw_context.t\n and type key = Zk_rollup_repr.t\n and type value = Zk_rollup_repr.pending_list\n\n module Pending_operation :\n Non_iterable_indexed_carbonated_data_storage\n with type t := Raw_context.t * Zk_rollup_repr.t\n and type key = int64\n and type value = Zk_rollup_operation_repr.t * Ticket_hash_repr.t option\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Storage_functors\nopen Storage_sigs\n\nmodule Encoding = struct\n module UInt16 : VALUE with type t = int = struct\n type t = int\n\n let encoding = Data_encoding.uint16\n end\n\n module Int32 : VALUE with type t = Int32.t = struct\n type t = Int32.t\n\n let encoding = Data_encoding.int32\n end\n\n module Int64 : VALUE with type t = Int64.t = struct\n type t = Int64.t\n\n let encoding = Data_encoding.int64\n end\n\n module Z : VALUE with type t = Z.t = struct\n type t = Z.t\n\n let encoding = Data_encoding.z\n end\n\n module Manager_counter : VALUE with type t = Manager_counter_repr.t = struct\n type t = Manager_counter_repr.t\n\n let encoding = Manager_counter_repr.encoding_for_storage\n end\nend\n\nmodule Int31_index : INDEX with type t = int = struct\n type t = int\n\n let path_length = 1\n\n let to_path c l = string_of_int c :: l\n\n let of_path = function [] | _ :: _ :: _ -> None | [c] -> int_of_string_opt c\n\n type 'a ipath = 'a * t\n\n let args =\n Storage_description.One\n {\n rpc_arg = RPC_arg.int;\n encoding = Data_encoding.int31;\n compare = Compare.Int.compare;\n }\nend\n\nmodule Make_index (H : Storage_description.INDEX) :\n INDEX with type t = H.t and type 'a ipath = 'a * H.t = struct\n include H\n\n type 'a ipath = 'a * t\n\n let args = Storage_description.One {rpc_arg; encoding; compare}\nend\n\nmodule type Simple_single_data_storage = sig\n type value\n\n val get : Raw_context.t -> value tzresult Lwt.t\n\n val update : Raw_context.t -> value -> Raw_context.t tzresult Lwt.t\n\n val init : Raw_context.t -> value -> Raw_context.t tzresult Lwt.t\nend\n\nmodule Block_round : Simple_single_data_storage with type value = Round_repr.t =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"block_round\"]\n end)\n (Round_repr)\n\nmodule Tenderbake = struct\n module First_level_of_protocol =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"first_level_of_protocol\"]\n end)\n (Raw_level_repr)\n\n module Branch = struct\n type t = Block_hash.t * Block_payload_hash.t\n\n let encoding =\n Data_encoding.(\n obj2\n (req \"grand_parent_hash\" Block_hash.encoding)\n (req \"predecessor_payload\" Block_payload_hash.encoding))\n end\n\n module Endorsement_branch =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"endorsement_branch\"]\n end)\n (Branch)\n\n module Grand_parent_branch =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"grand_parent_branch\"]\n end)\n (Branch)\nend\n\n(** Contracts handling *)\n\ntype deposits = {initial_amount : Tez_repr.t; current_amount : Tez_repr.t}\n\nmodule Deposits = struct\n type t = deposits\n\n let encoding =\n let open Data_encoding in\n conv\n (fun {initial_amount; current_amount} -> (initial_amount, current_amount))\n (fun (initial_amount, current_amount) -> {initial_amount; current_amount})\n (obj2\n (req \"initial_amount\" Tez_repr.encoding)\n (req \"actual_amount\" Tez_repr.encoding))\nend\n\ntype missed_endorsements_info = {remaining_slots : int; missed_levels : int}\n\nmodule Missed_endorsements_info = struct\n type t = missed_endorsements_info\n\n let encoding =\n let open Data_encoding in\n conv\n (fun {remaining_slots; missed_levels} -> (remaining_slots, missed_levels))\n (fun (remaining_slots, missed_levels) -> {remaining_slots; missed_levels})\n (obj2 (req \"remaining_slots\" int31) (req \"missed_levels\" int31))\nend\n\nmodule Contract = struct\n module Raw_context =\n Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"contracts\"]\n end)\n\n module Global_counter :\n Simple_single_data_storage with type value = Manager_counter_repr.t =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"global_counter\"]\n end)\n (Encoding.Manager_counter)\n\n module Indexed_context =\n Make_indexed_subcontext\n (Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"index\"]\n end))\n (Make_index (Contract_repr.Index))\n\n let fold = Indexed_context.fold_keys\n\n let list = Indexed_context.keys\n\n type local_context = Indexed_context.local_context\n\n let with_local_context = Indexed_context.with_local_context\n\n module Spendable_balance =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"balance\"]\n end)\n (Tez_repr)\n\n module Missed_endorsements =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"missed_endorsements\"]\n end)\n (Missed_endorsements_info)\n\n module Manager =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"manager\"]\n end)\n (Manager_repr)\n\n module Consensus_key =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"consensus_key\"; \"active\"]\n end)\n (Signature.Public_key)\n\n module Pending_consensus_keys =\n Make_indexed_data_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"consensus_key\"; \"pendings\"]\n end))\n (Make_index (Cycle_repr.Index))\n (Signature.Public_key)\n\n module Delegate =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"delegate\"]\n end)\n (Signature.Public_key_hash)\n\n module Inactive_delegate =\n Indexed_context.Make_set\n (Registered)\n (struct\n let name = [\"inactive_delegate\"]\n end)\n\n module Delegate_last_cycle_before_deactivation =\n Indexed_context.Make_map\n (Registered)\n (struct\n (* FIXME? Change the key name to reflect the functor's name *)\n let name = [\"delegate_desactivation\"]\n end)\n (Cycle_repr)\n\n module Delegated =\n Make_data_set_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"delegated\"]\n end))\n (Make_index (Contract_repr.Index))\n\n module Counter =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"counter\"]\n end)\n (Encoding.Manager_counter)\n\n (* Consume gas for serialization and deserialization of expr in this\n module *)\n module Make_carbonated_map_expr (N : Storage_sigs.NAME) :\n Storage_sigs.Non_iterable_indexed_carbonated_data_storage\n with type key = Contract_repr.t\n and type value = Script_repr.lazy_expr\n and type t := Raw_context.t = struct\n module I =\n Indexed_context.Make_carbonated_map (Registered) (N)\n (struct\n type t = Script_repr.lazy_expr\n\n let encoding = Script_repr.lazy_expr_encoding\n end)\n\n type context = I.context\n\n type key = I.key\n\n type value = I.value\n\n let mem = I.mem\n\n let remove_existing = I.remove_existing\n\n let remove = I.remove\n\n let consume_deserialize_gas ctxt value =\n Raw_context.consume_gas ctxt (Script_repr.force_decode_cost value)\n\n let consume_serialize_gas ctxt value =\n Raw_context.consume_gas ctxt (Script_repr.force_bytes_cost value)\n\n let get ctxt contract =\n I.get ctxt contract >>=? fun (ctxt, value) ->\n Lwt.return\n (consume_deserialize_gas ctxt value >|? fun ctxt -> (ctxt, value))\n\n let find ctxt contract =\n I.find ctxt contract >>=? fun (ctxt, value_opt) ->\n Lwt.return\n @@\n match value_opt with\n | None -> ok (ctxt, None)\n | Some value ->\n consume_deserialize_gas ctxt value >|? fun ctxt -> (ctxt, value_opt)\n\n let update ctxt contract value =\n consume_serialize_gas ctxt value >>?= fun ctxt ->\n I.update ctxt contract value\n\n let add_or_remove ctxt contract value_opt =\n match value_opt with\n | None -> I.add_or_remove ctxt contract None\n | Some value ->\n consume_serialize_gas ctxt value >>?= fun ctxt ->\n I.add_or_remove ctxt contract value_opt\n\n let init ctxt contract value =\n consume_serialize_gas ctxt value >>?= fun ctxt ->\n I.init ctxt contract value\n\n let add ctxt contract value =\n consume_serialize_gas ctxt value >>?= fun ctxt ->\n I.add ctxt contract value\n\n let keys_unaccounted = I.keys_unaccounted\n end\n\n module Code = Make_carbonated_map_expr (struct\n let name = [\"code\"]\n end)\n\n module Storage = Make_carbonated_map_expr (struct\n let name = [\"storage\"]\n end)\n\n module Paid_storage_space =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"paid_bytes\"]\n end)\n (Encoding.Z)\n\n module Used_storage_space =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"used_bytes\"]\n end)\n (Encoding.Z)\n\n module Frozen_deposits =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"frozen_deposits\"]\n end)\n (Deposits)\n\n module Frozen_deposits_limit =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"frozen_deposits_limit\"]\n end)\n (Tez_repr)\n\n module Bond_id_index =\n Make_indexed_subcontext\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"bond_id_index\"]\n end))\n (Make_index (Bond_id_repr.Index))\n\n module Frozen_bonds =\n Bond_id_index.Make_carbonated_map\n (Registered)\n (struct\n let name = [\"frozen_bonds\"]\n end)\n (Tez_repr)\n\n let fold_bond_ids = Bond_id_index.fold_keys\n\n module Total_frozen_bonds =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"total_frozen_bonds\"]\n end)\n (Tez_repr)\nend\n\nmodule type NEXT = sig\n type id\n\n val init : Raw_context.t -> Raw_context.t tzresult Lwt.t\n\n val incr : Raw_context.t -> (Raw_context.t * id) tzresult Lwt.t\nend\n\nmodule Global_constants = struct\n module Map :\n Non_iterable_indexed_carbonated_data_storage\n with type t := Raw_context.t\n and type key = Script_expr_hash.t\n and type value = Script_repr.expr =\n Make_indexed_carbonated_data_storage\n (Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"global_constant\"]\n end))\n (Make_index (Script_expr_hash))\n (struct\n type t = Script_repr.expr\n\n let encoding = Script_repr.expr_encoding\n end)\nend\n\n(** Big maps handling *)\n\nmodule Big_map = struct\n type id = Lazy_storage_kind.Big_map.Id.t\n\n module Raw_context =\n Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"big_maps\"]\n end)\n\n module Next : NEXT with type id := id = struct\n module Storage =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"next\"]\n end)\n (Lazy_storage_kind.Big_map.Id)\n\n let incr ctxt =\n Storage.get ctxt >>=? fun i ->\n Storage.update ctxt (Lazy_storage_kind.Big_map.Id.next i) >|=? fun ctxt ->\n (ctxt, i)\n\n let init ctxt = Storage.init ctxt Lazy_storage_kind.Big_map.Id.init\n end\n\n module Index = Lazy_storage_kind.Big_map.Id\n\n module Indexed_context =\n Make_indexed_subcontext\n (Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"index\"]\n end))\n (Make_index (Index))\n\n let rpc_arg = Index.rpc_arg\n\n let fold = Indexed_context.fold_keys\n\n let list = Indexed_context.keys\n\n let remove ctxt n = Indexed_context.remove ctxt n\n\n let copy ctxt ~from ~to_ = Indexed_context.copy ctxt ~from ~to_\n\n type key = Raw_context.t * Index.t\n\n module Total_bytes =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"total_bytes\"]\n end)\n (Encoding.Z)\n\n module Key_type =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"key_type\"]\n end)\n (struct\n type t = Script_repr.expr\n\n let encoding = Script_repr.expr_encoding\n end)\n\n module Value_type =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"value_type\"]\n end)\n (struct\n type t = Script_repr.expr\n\n let encoding = Script_repr.expr_encoding\n end)\n\n module Contents = struct\n module I =\n Storage_functors.Make_indexed_carbonated_data_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"contents\"]\n end))\n (Make_index (Script_expr_hash))\n (struct\n type t = Script_repr.expr\n\n let encoding = Script_repr.expr_encoding\n end)\n\n type context = I.context\n\n type key = I.key\n\n type value = I.value\n\n let mem = I.mem\n\n let remove_existing = I.remove_existing\n\n let remove = I.remove\n\n let update = I.update\n\n let add_or_remove = I.add_or_remove\n\n let init = I.init\n\n let add = I.add\n\n let list_key_values = I.list_key_values\n\n let consume_deserialize_gas ctxt value =\n Raw_context.consume_gas ctxt (Script_repr.deserialized_cost value)\n\n let get ctxt contract =\n I.get ctxt contract >>=? fun (ctxt, value) ->\n Lwt.return\n (consume_deserialize_gas ctxt value >|? fun ctxt -> (ctxt, value))\n\n let find ctxt contract =\n I.find ctxt contract >>=? fun (ctxt, value_opt) ->\n Lwt.return\n @@\n match value_opt with\n | None -> ok (ctxt, None)\n | Some value ->\n consume_deserialize_gas ctxt value >|? fun ctxt -> (ctxt, value_opt)\n\n let keys_unaccounted = I.keys_unaccounted\n end\nend\n\nmodule Sapling = struct\n type id = Lazy_storage_kind.Sapling_state.Id.t\n\n module Raw_context =\n Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"sapling\"]\n end)\n\n module Next = struct\n module Storage =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"next\"]\n end)\n (Lazy_storage_kind.Sapling_state.Id)\n\n let incr ctxt =\n Storage.get ctxt >>=? fun i ->\n Storage.update ctxt (Lazy_storage_kind.Sapling_state.Id.next i)\n >|=? fun ctxt -> (ctxt, i)\n\n let init ctxt = Storage.init ctxt Lazy_storage_kind.Sapling_state.Id.init\n end\n\n module Index = Lazy_storage_kind.Sapling_state.Id\n\n let rpc_arg = Index.rpc_arg\n\n module Indexed_context =\n Make_indexed_subcontext\n (Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"index\"]\n end))\n (Make_index (Index))\n\n let remove ctxt n = Indexed_context.remove ctxt n\n\n let copy ctxt ~from ~to_ = Indexed_context.copy ctxt ~from ~to_\n\n module Total_bytes =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"total_bytes\"]\n end)\n (Encoding.Z)\n\n module Commitments_size =\n Make_single_data_storage (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"commitments_size\"]\n end)\n (Encoding.Int64)\n\n module Memo_size =\n Make_single_data_storage (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"memo_size\"]\n end)\n (Sapling_repr.Memo_size)\n\n module Commitments :\n Non_iterable_indexed_carbonated_data_storage\n with type t := Raw_context.t * id\n and type key = int64\n and type value = Sapling.Hash.t =\n Make_indexed_carbonated_data_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"commitments\"]\n end))\n (Make_index (struct\n type t = int64\n\n let rpc_arg =\n let construct = Int64.to_string in\n let destruct hash =\n Int64.of_string_opt hash\n |> Result.of_option ~error:\"Cannot parse node position\"\n in\n RPC_arg.make\n ~descr:\"The position of a node in a sapling commitment tree\"\n ~name:\"sapling_node_position\"\n ~construct\n ~destruct\n ()\n\n let encoding =\n Data_encoding.def\n \"sapling_node_position\"\n ~title:\"Sapling node position\"\n ~description:\n \"The position of a node in a sapling commitment tree\"\n Data_encoding.int64\n\n let compare = Compare.Int64.compare\n\n let path_length = 1\n\n let to_path c l = Int64.to_string c :: l\n\n let of_path = function [c] -> Int64.of_string_opt c | _ -> None\n end))\n (Sapling.Hash)\n\n let commitments_init ctx id =\n Indexed_context.Raw_context.remove (ctx, id) [\"commitments\"]\n >|= fun (ctx, _id) -> ctx\n\n module Ciphertexts :\n Non_iterable_indexed_carbonated_data_storage\n with type t := Raw_context.t * id\n and type key = int64\n and type value = Sapling.Ciphertext.t =\n Make_indexed_carbonated_data_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"ciphertexts\"]\n end))\n (Make_index (struct\n type t = int64\n\n let rpc_arg =\n let construct = Int64.to_string in\n let destruct hash =\n Int64.of_string_opt hash\n |> Result.of_option ~error:\"Cannot parse ciphertext position\"\n in\n RPC_arg.make\n ~descr:\"The position of a sapling ciphertext\"\n ~name:\"sapling_ciphertext_position\"\n ~construct\n ~destruct\n ()\n\n let encoding =\n Data_encoding.def\n \"sapling_ciphertext_position\"\n ~title:\"Sapling ciphertext position\"\n ~description:\"The position of a sapling ciphertext\"\n Data_encoding.int64\n\n let compare = Compare.Int64.compare\n\n let path_length = 1\n\n let to_path c l = Int64.to_string c :: l\n\n let of_path = function [c] -> Int64.of_string_opt c | _ -> None\n end))\n (Sapling.Ciphertext)\n\n let ciphertexts_init ctx id =\n Indexed_context.Raw_context.remove (ctx, id) [\"commitments\"]\n >|= fun (ctx, _id) -> ctx\n\n module Nullifiers_size =\n Make_single_data_storage (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"nullifiers_size\"]\n end)\n (Encoding.Int64)\n\n (* For sequential access when building a diff *)\n module Nullifiers_ordered :\n Non_iterable_indexed_data_storage\n with type t := Raw_context.t * id\n and type key = int64\n and type value = Sapling.Nullifier.t =\n Make_indexed_data_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"nullifiers_ordered\"]\n end))\n (Make_index (struct\n type t = int64\n\n let rpc_arg =\n let construct = Int64.to_string in\n let destruct hash =\n Int64.of_string_opt hash\n |> Result.of_option ~error:\"Cannot parse nullifier position\"\n in\n RPC_arg.make\n ~descr:\"A sapling nullifier position\"\n ~name:\"sapling_nullifier_position\"\n ~construct\n ~destruct\n ()\n\n let encoding =\n Data_encoding.def\n \"sapling_nullifier_position\"\n ~title:\"Sapling nullifier position\"\n ~description:\"Sapling nullifier position\"\n Data_encoding.int64\n\n let compare = Compare.Int64.compare\n\n let path_length = 1\n\n let to_path c l = Int64.to_string c :: l\n\n let of_path = function [c] -> Int64.of_string_opt c | _ -> None\n end))\n (Sapling.Nullifier)\n\n (* Check membership in O(1) for verify_update *)\n module Nullifiers_hashed =\n Make_carbonated_data_set_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"nullifiers_hashed\"]\n end))\n (Make_index (struct\n type t = Sapling.Nullifier.t\n\n let encoding = Sapling.Nullifier.encoding\n\n let of_string hexstring =\n Option.bind\n (Hex.to_bytes (`Hex hexstring))\n (Data_encoding.Binary.of_bytes_opt encoding)\n |> Result.of_option ~error:\"Cannot parse sapling nullifier\"\n\n let to_string nf =\n let b = Data_encoding.Binary.to_bytes_exn encoding nf in\n let (`Hex hexstring) = Hex.of_bytes b in\n hexstring\n\n let rpc_arg =\n RPC_arg.make\n ~descr:\"A sapling nullifier\"\n ~name:\"sapling_nullifier\"\n ~construct:to_string\n ~destruct:of_string\n ()\n\n let compare = Sapling.Nullifier.compare\n\n let path_length = 1\n\n let to_path c l = to_string c :: l\n\n let of_path = function\n | [c] -> Result.to_option (of_string c)\n | _ -> None\n end))\n\n let nullifiers_init ctx id =\n Nullifiers_size.add (ctx, id) Int64.zero >>= fun ctx ->\n Indexed_context.Raw_context.remove (ctx, id) [\"nullifiers_ordered\"]\n >>= fun (ctx, id) ->\n Indexed_context.Raw_context.remove (ctx, id) [\"nullifiers_hashed\"]\n >|= fun (ctx, _id) -> ctx\n\n module Roots :\n Non_iterable_indexed_data_storage\n with type t := Raw_context.t * id\n and type key = int32\n and type value = Sapling.Hash.t =\n Make_indexed_data_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"roots\"]\n end))\n (Make_index (struct\n type t = int32\n\n let rpc_arg =\n let construct = Int32.to_string in\n let destruct hash =\n Int32.of_string_opt hash\n |> Result.of_option ~error:\"Cannot parse nullifier position\"\n in\n RPC_arg.make\n ~descr:\"A sapling root\"\n ~name:\"sapling_root\"\n ~construct\n ~destruct\n ()\n\n let encoding =\n Data_encoding.def\n \"sapling_root\"\n ~title:\"Sapling root\"\n ~description:\"Sapling root\"\n Data_encoding.int32\n\n let compare = Compare.Int32.compare\n\n let path_length = 1\n\n let to_path c l = Int32.to_string c :: l\n\n let of_path = function [c] -> Int32.of_string_opt c | _ -> None\n end))\n (Sapling.Hash)\n\n module Roots_pos =\n Make_single_data_storage (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"roots_pos\"]\n end)\n (Encoding.Int32)\n\n module Roots_level =\n Make_single_data_storage (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"roots_level\"]\n end)\n (Raw_level_repr)\nend\n\nmodule Public_key_hash = struct\n open Signature\n include Signature.Public_key_hash\n module Path_Ed25519 = Path_encoding.Make_hex (Ed25519.Public_key_hash)\n module Path_Secp256k1 = Path_encoding.Make_hex (Secp256k1.Public_key_hash)\n module Path_P256 = Path_encoding.Make_hex (P256.Public_key_hash)\n module Path_Bls = Path_encoding.Make_hex (Bls.Public_key_hash)\n\n let to_path (key : public_key_hash) l =\n match key with\n | Ed25519 h -> \"ed25519\" :: Path_Ed25519.to_path h l\n | Secp256k1 h -> \"secp256k1\" :: Path_Secp256k1.to_path h l\n | P256 h -> \"p256\" :: Path_P256.to_path h l\n | Bls h -> \"bls\" :: Path_Bls.to_path h l\n\n let of_path : _ -> public_key_hash option = function\n | \"ed25519\" :: rest -> (\n match Path_Ed25519.of_path rest with\n | Some pkh -> Some (Ed25519 pkh)\n | None -> None)\n | \"secp256k1\" :: rest -> (\n match Path_Secp256k1.of_path rest with\n | Some pkh -> Some (Secp256k1 pkh)\n | None -> None)\n | \"p256\" :: rest -> (\n match Path_P256.of_path rest with\n | Some pkh -> Some (P256 pkh)\n | None -> None)\n | \"bls\" :: rest -> (\n match Path_Bls.of_path rest with\n | Some pkh -> Some (Bls pkh)\n | None -> None)\n | _ -> None\n\n let path_length =\n let l1 = Path_Ed25519.path_length\n and l2 = Path_Secp256k1.path_length\n and l3 = Path_P256.path_length\n and l4 = Path_Bls.path_length in\n assert (Compare.Int.(l1 = l2 && l2 = l3 && l3 = l4)) ;\n l1 + 1\nend\n\nmodule Public_key_hash_index = Make_index (Public_key_hash)\n\nmodule Protocol_hash_with_path_encoding = struct\n include Protocol_hash\n include Path_encoding.Make_hex (Protocol_hash)\nend\n\nmodule Delegates =\n Make_data_set_storage\n (Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"delegates\"]\n end))\n (Public_key_hash_index)\n\nmodule Consensus_keys =\n Make_data_set_storage\n (Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"consensus_keys\"]\n end))\n (Public_key_hash_index)\n\n(** Per cycle storage *)\n\ntype slashed_level = {for_double_endorsing : bool; for_double_baking : bool}\n\nmodule Slashed_level = struct\n type t = slashed_level\n\n let encoding =\n let open Data_encoding in\n conv\n (fun {for_double_endorsing; for_double_baking} ->\n (for_double_endorsing, for_double_baking))\n (fun (for_double_endorsing, for_double_baking) ->\n {for_double_endorsing; for_double_baking})\n (obj2 (req \"for_double_endorsing\" bool) (req \"for_double_baking\" bool))\nend\n\nmodule Cycle = struct\n module Indexed_context =\n Make_indexed_subcontext\n (Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"cycle\"]\n end))\n (Make_index (Cycle_repr.Index))\n\n module Slashed_deposits =\n Make_indexed_data_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"slashed_deposits\"]\n end))\n (Pair (Make_index (Raw_level_repr.Index)) (Public_key_hash_index))\n (Slashed_level)\n\n module Selected_stake_distribution =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"selected_stake_distribution\"]\n end)\n (struct\n type t = (Signature.Public_key_hash.t * Tez_repr.t) list\n\n let encoding =\n Data_encoding.(\n Variable.list\n (obj2\n (req \"baker\" Signature.Public_key_hash.encoding)\n (req \"active_stake\" Tez_repr.encoding)))\n end)\n\n module Total_active_stake =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"total_active_stake\"]\n end)\n (Tez_repr)\n\n module Delegate_sampler_state =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"delegate_sampler_state\"]\n end)\n (struct\n type t = Raw_context.consensus_pk Sampler.t\n\n let encoding = Sampler.encoding Raw_context.consensus_pk_encoding\n end)\n\n type unrevealed_nonce = {\n nonce_hash : Nonce_hash.t;\n delegate : Signature.Public_key_hash.t;\n }\n\n type nonce_status =\n | Unrevealed of unrevealed_nonce\n | Revealed of Seed_repr.nonce\n\n let nonce_status_encoding =\n let open Data_encoding in\n union\n [\n case\n (Tag 0)\n ~title:\"Unrevealed\"\n (tup2 Nonce_hash.encoding Signature.Public_key_hash.encoding)\n (function\n | Unrevealed {nonce_hash; delegate} -> Some (nonce_hash, delegate)\n | _ -> None)\n (fun (nonce_hash, delegate) -> Unrevealed {nonce_hash; delegate});\n case\n (Tag 1)\n ~title:\"Revealed\"\n Seed_repr.nonce_encoding\n (function Revealed nonce -> Some nonce | _ -> None)\n (fun nonce -> Revealed nonce);\n ]\n\n module Nonce =\n Make_indexed_data_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"nonces\"]\n end))\n (Make_index (Raw_level_repr.Index))\n (struct\n type t = nonce_status\n\n let encoding = nonce_status_encoding\n end)\n\n module Seed =\n Indexed_context.Make_map\n (Registered)\n (struct\n let name = [\"random_seed\"]\n end)\n (struct\n type t = Seed_repr.seed\n\n let encoding = Seed_repr.seed_encoding\n end)\nend\n\nmodule Slashed_deposits = Cycle.Slashed_deposits\n\nmodule Stake = struct\n module Staking_balance =\n Make_indexed_data_snapshotable_storage\n (Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"staking_balance\"]\n end))\n (Int31_index)\n (Public_key_hash_index)\n (Tez_repr)\n\n module Active_delegates_with_minimal_stake =\n Make_indexed_data_snapshotable_storage\n (Make_subcontext (Registered) (Raw_context)\n (struct\n (* This name is for historical reasons, when the stake was\n expressed in rolls (that is, pre-Ithaca). *)\n let name = [\"active_delegate_with_one_roll\"]\n end))\n (Int31_index)\n (Public_key_hash_index)\n (struct\n type t = unit\n\n let encoding = Data_encoding.unit\n end)\n\n module Selected_distribution_for_cycle = Cycle.Selected_stake_distribution\n module Total_active_stake = Cycle.Total_active_stake\n\n (* This is an index that is set to 0 by calls to\n {!val:Stake_storage.selected_new_distribution_at_cycle_end} and\n incremented (by 1) by calls to {!val:Stake_storage.snapshot}.\n\n {!val:Stake_storage.snapshot} is called in relation with constant\n [blocks_per_stake_snapshot] in\n {!val:Level_storage.may_snapshot_stake_distribution}.\n\n That is, the increment is done every [blocks_per_stake_snaphot]\n blocks and reset at the end of cycles. So, it goes up to\n [blocks_per_cycle / blocks_per_stake_snaphot], which is currently\n 16 (= 8192/512 -- the concrete values can be found in\n {!val:Default_parameters.constants_mainnet}), then comes back to\n 0, so that a UInt16 is big enough.\n\n The ratio [blocks_per_cycle / blocks_per_stake_snapshot] above is\n checked in {!val:Constants_repr.check_constants} to fit in a\n UInt16. *)\n module Last_snapshot =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"last_snapshot\"]\n end)\n (Encoding.UInt16)\nend\n\nmodule Delegate_sampler_state = Cycle.Delegate_sampler_state\n\n(** Votes *)\n\nmodule Vote = struct\n module Raw_context =\n Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"votes\"]\n end)\n\n module Pred_period_kind =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"pred_period_kind\"]\n end)\n (struct\n type t = Voting_period_repr.kind\n\n let encoding = Voting_period_repr.kind_encoding\n end)\n\n module Current_period =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"current_period\"]\n end)\n (struct\n type t = Voting_period_repr.t\n\n let encoding = Voting_period_repr.encoding\n end)\n\n module Participation_ema =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"participation_ema\"]\n end)\n (Encoding.Int32)\n\n module Current_proposal =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"current_proposal\"]\n end)\n (Protocol_hash)\n\n module Voting_power_in_listings =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"voting_power_in_listings\"]\n end)\n (Encoding.Int64)\n\n module Listings =\n Make_indexed_data_storage\n (Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"listings\"]\n end))\n (Public_key_hash_index)\n (Encoding.Int64)\n\n module Proposals =\n Make_data_set_storage\n (Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"proposals\"]\n end))\n (Pair\n (Make_index\n (Protocol_hash_with_path_encoding))\n (Public_key_hash_index))\n\n module Proposals_count =\n Make_indexed_data_storage\n (Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"proposals_count\"]\n end))\n (Public_key_hash_index)\n (Encoding.UInt16)\n\n module Ballots =\n Make_indexed_data_storage\n (Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"ballots\"]\n end))\n (Public_key_hash_index)\n (struct\n type t = Vote_repr.ballot\n\n let encoding = Vote_repr.ballot_encoding\n end)\nend\n\nmodule type FOR_CYCLE = sig\n val init :\n Raw_context.t ->\n Cycle_repr.t ->\n Seed_repr.seed ->\n Raw_context.t tzresult Lwt.t\n\n val mem : Raw_context.t -> Cycle_repr.t -> bool Lwt.t\n\n val get : Raw_context.t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t\n\n val update :\n Raw_context.t ->\n Cycle_repr.t ->\n Seed_repr.seed ->\n Seed_repr.seed_status ->\n Raw_context.t tzresult Lwt.t\n\n val remove_existing :\n Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t\nend\n\n(** Seed *)\n\nmodule Seed_status =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"seed_status\"]\n end)\n (struct\n type t = Seed_repr.seed_status\n\n let encoding = Seed_repr.seed_status_encoding\n end)\n\nmodule Seed = struct\n type unrevealed_nonce = Cycle.unrevealed_nonce = {\n nonce_hash : Nonce_hash.t;\n delegate : Signature.Public_key_hash.t;\n }\n\n type nonce_status = Cycle.nonce_status =\n | Unrevealed of unrevealed_nonce\n | Revealed of Seed_repr.nonce\n\n module Nonce :\n Non_iterable_indexed_data_storage\n with type key := Level_repr.t\n and type value := nonce_status\n and type t := Raw_context.t = struct\n open Level_repr\n\n type context = Raw_context.t\n\n let mem ctxt (l : Level_repr.t) = Cycle.Nonce.mem (ctxt, l.cycle) l.level\n\n let get ctxt (l : Level_repr.t) = Cycle.Nonce.get (ctxt, l.cycle) l.level\n\n let find ctxt (l : Level_repr.t) = Cycle.Nonce.find (ctxt, l.cycle) l.level\n\n let update ctxt (l : Level_repr.t) v =\n Cycle.Nonce.update (ctxt, l.cycle) l.level v\n\n let init ctxt (l : Level_repr.t) v =\n Cycle.Nonce.init (ctxt, l.cycle) l.level v\n\n let add ctxt (l : Level_repr.t) v =\n Cycle.Nonce.add (ctxt, l.cycle) l.level v\n\n let add_or_remove ctxt (l : Level_repr.t) v =\n Cycle.Nonce.add_or_remove (ctxt, l.cycle) l.level v\n\n let remove_existing ctxt (l : Level_repr.t) =\n Cycle.Nonce.remove_existing (ctxt, l.cycle) l.level\n\n let remove ctxt (l : Level_repr.t) =\n Cycle.Nonce.remove (ctxt, l.cycle) l.level\n end\n\n module VDF_setup =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"vdf_challenge\"]\n end)\n (struct\n type t = Seed_repr.vdf_setup\n\n let encoding = Seed_repr.vdf_setup_encoding\n end)\n\n module For_cycle : FOR_CYCLE = struct\n let init ctxt cycle seed =\n let open Lwt_result_syntax in\n let* ctxt = Cycle.Seed.init ctxt cycle seed in\n let*! ctxt = Seed_status.add ctxt Seed_repr.RANDAO_seed in\n return ctxt\n\n let mem = Cycle.Seed.mem\n\n let get = Cycle.Seed.get\n\n let update ctxt cycle seed status =\n Cycle.Seed.update ctxt cycle seed >>=? fun ctxt ->\n Seed_status.update ctxt status\n\n let remove_existing = Cycle.Seed.remove_existing\n end\n\n let get_status = Seed_status.get\nend\n\n(** Commitments *)\n\nmodule Commitments =\n Make_indexed_data_storage\n (Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"commitments\"]\n end))\n (Make_index (Blinded_public_key_hash.Index))\n (Tez_repr)\n\n(** Ramp up rewards... *)\n\nmodule Ramp_up = struct\n type reward = {\n baking_reward_fixed_portion : Tez_repr.t;\n baking_reward_bonus_per_slot : Tez_repr.t;\n endorsing_reward_per_slot : Tez_repr.t;\n }\n\n module Rewards =\n Make_indexed_data_storage\n (Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"ramp_up\"; \"rewards\"]\n end))\n (Make_index (Cycle_repr.Index))\n (struct\n type t = reward\n\n let encoding =\n Data_encoding.(\n conv\n (fun {\n baking_reward_fixed_portion;\n baking_reward_bonus_per_slot;\n endorsing_reward_per_slot;\n } ->\n ( baking_reward_fixed_portion,\n baking_reward_bonus_per_slot,\n endorsing_reward_per_slot ))\n (fun ( baking_reward_fixed_portion,\n baking_reward_bonus_per_slot,\n endorsing_reward_per_slot ) ->\n {\n baking_reward_fixed_portion;\n baking_reward_bonus_per_slot;\n endorsing_reward_per_slot;\n })\n (obj3\n (req \"baking_reward_fixed_portion\" Tez_repr.encoding)\n (req \"baking_reward_bonus_per_slot\" Tez_repr.encoding)\n (req \"endorsing_reward_per_slot\" Tez_repr.encoding)))\n end)\nend\n\nmodule Pending_migration = struct\n module Balance_updates =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"pending_migration_balance_updates\"]\n end)\n (struct\n type t = Receipt_repr.balance_updates\n\n let encoding = Receipt_repr.balance_updates_encoding\n end)\n\n module Operation_results =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"pending_migration_operation_results\"]\n end)\n (struct\n type t = Migration_repr.origination_result list\n\n let encoding = Migration_repr.origination_result_list_encoding\n end)\n\n let remove ctxt =\n let balance_updates ctxt =\n Balance_updates.find ctxt >>=? function\n | Some balance_updates ->\n Balance_updates.remove ctxt >>= fun ctxt ->\n (* When applying balance updates in a migration, we must attach receipts.\n The balance updates returned from here will be applied in the first\n block of the new protocol. *)\n return (ctxt, balance_updates)\n | None -> return (ctxt, [])\n in\n let operation_results ctxt =\n Operation_results.find ctxt >>=? function\n | Some operation_results ->\n Operation_results.remove ctxt >>= fun ctxt ->\n return (ctxt, operation_results)\n | None -> return (ctxt, [])\n in\n balance_updates ctxt >>=? fun (ctxt, balance_updates) ->\n operation_results ctxt >>=? fun (ctxt, operation_results) ->\n return (ctxt, balance_updates, operation_results)\nend\n\nmodule Liquidity_baking = struct\n module Toggle_ema =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n (* The old \"escape\" name is kept here to avoid migrating this. *)\n let name = [\"liquidity_baking_escape_ema\"]\n end)\n (Encoding.Int32)\n\n module Cpmm_address =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"liquidity_baking_cpmm_address\"]\n end)\n (struct\n type t = Contract_hash.t\n\n (* Keeping contract-compatible encoding to avoid migrating this. *)\n let encoding = Contract_repr.originated_encoding\n end)\nend\n\nmodule Ticket_balance = struct\n module Name = struct\n let name = [\"ticket_balance\"]\n end\n\n module Raw_context = Make_subcontext (Registered) (Raw_context) (Name)\n\n module Paid_storage_space =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"paid_bytes\"]\n end)\n (Encoding.Z)\n\n module Used_storage_space =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"used_bytes\"]\n end)\n (Encoding.Z)\n\n module Table_context =\n Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"table\"]\n end)\n\n module Index = Make_index (Ticket_hash_repr.Index)\n module Table =\n Make_indexed_carbonated_data_storage (Table_context) (Index) (Encoding.Z)\nend\n\nmodule Tx_rollup = struct\n module Indexed_context =\n Make_indexed_subcontext\n (Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"tx_rollup\"]\n end))\n (Make_index (Tx_rollup_repr.Index))\n\n module State =\n Indexed_context.Make_carbonated_map\n (Registered)\n (struct\n let name = [\"state\"]\n end)\n (Tx_rollup_state_repr)\n\n module Level_context =\n Make_indexed_subcontext\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"tx_level\"]\n end))\n (Make_index (Tx_rollup_level_repr.Index))\n\n module Inbox =\n Level_context.Make_carbonated_map\n (Registered)\n (struct\n let name = [\"inbox\"]\n end)\n (struct\n type t = Tx_rollup_inbox_repr.t\n\n let encoding = Tx_rollup_inbox_repr.encoding\n end)\n\n module Revealed_withdrawals =\n Level_context.Make_carbonated_map\n (Registered)\n (struct\n let name = [\"withdrawals\"]\n end)\n (Bitset)\n\n module Commitment =\n Level_context.Make_carbonated_map\n (Registered)\n (struct\n let name = [\"commitment\"]\n end)\n (Tx_rollup_commitment_repr.Submitted_commitment)\n\n module Bond_indexed_context =\n Make_indexed_subcontext\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"bond\"]\n end))\n (Public_key_hash_index)\n\n module Commitment_bond =\n Bond_indexed_context.Make_carbonated_map\n (Registered)\n (struct\n let name = [\"commitment\"]\n end)\n (struct\n type t = int\n\n let encoding = Data_encoding.int31\n end)\nend\n\nmodule Sc_rollup = struct\n module Raw_context =\n Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"smart_rollup\"]\n end)\n\n module Indexed_context =\n Make_indexed_subcontext\n (Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"index\"]\n end))\n (Make_index (Sc_rollup_repr.Index))\n\n module Make_versioned\n (Versioned_value : Sc_rollup_data_version_sig.S) (Data_storage : sig\n type context\n\n type key\n\n type value = Versioned_value.versioned\n\n val get : context -> key -> (Raw_context.t * value) tzresult Lwt.t\n\n val find :\n context -> key -> (Raw_context.t * value option) tzresult Lwt.t\n\n val update :\n context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t\n\n val init :\n context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t\n\n val add :\n context -> key -> value -> (Raw_context.t * int * bool) tzresult Lwt.t\n\n val add_or_remove :\n context ->\n key ->\n value option ->\n (Raw_context.t * int * bool) tzresult Lwt.t\n end) =\n struct\n include Data_storage\n\n type value = Versioned_value.t\n\n let get ctxt key =\n let open Lwt_result_syntax in\n let* ctxt, versioned = get ctxt key in\n return (ctxt, Versioned_value.of_versioned versioned)\n\n let find ctxt key =\n let open Lwt_result_syntax in\n let* ctxt, versioned = find ctxt key in\n return (ctxt, Option.map Versioned_value.of_versioned versioned)\n\n let update ctxt key value =\n update ctxt key (Versioned_value.to_versioned value)\n\n let init ctxt key value = init ctxt key (Versioned_value.to_versioned value)\n\n let add ctxt key value = add ctxt key (Versioned_value.to_versioned value)\n\n let add_or_remove ctxt key value =\n add_or_remove ctxt key (Option.map Versioned_value.to_versioned value)\n end\n\n module PVM_kind =\n Indexed_context.Make_carbonated_map\n (Registered)\n (struct\n let name = [\"kind\"]\n end)\n (struct\n type t = Sc_rollups.Kind.t\n\n let encoding = Sc_rollups.Kind.encoding\n end)\n\n module Parameters_type =\n Indexed_context.Make_carbonated_map\n (Registered)\n (struct\n let name = [\"parameters_type\"]\n end)\n (struct\n type t = Script_repr.lazy_expr\n\n let encoding = Script_repr.lazy_expr_encoding\n end)\n\n module Genesis_info =\n Indexed_context.Make_carbonated_map\n (Registered)\n (struct\n let name = [\"genesis_info\"]\n end)\n (struct\n type t = Sc_rollup_commitment_repr.genesis_info\n\n let encoding = Sc_rollup_commitment_repr.genesis_info_encoding\n end)\n\n module Inbox = struct\n include\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"inbox\"]\n end)\n (struct\n type t = Sc_rollup_inbox_repr.versioned\n\n let encoding = Sc_rollup_inbox_repr.versioned_encoding\n end)\n\n type value = Sc_rollup_inbox_repr.t\n\n let of_versioned = Sc_rollup_inbox_repr.of_versioned\n\n let to_versioned = Sc_rollup_inbox_repr.to_versioned\n\n let get ctxt =\n let open Lwt_result_syntax in\n let* versioned = get ctxt in\n return (of_versioned versioned)\n\n let find ctxt =\n let open Lwt_result_syntax in\n let* versioned = find ctxt in\n return (Option.map of_versioned versioned)\n\n let init ctxt value = init ctxt (to_versioned value)\n\n let update ctxt value = update ctxt (to_versioned value)\n\n let add ctxt value =\n let versioned = to_versioned value in\n add ctxt versioned\n\n let add_or_remove ctxt value =\n add_or_remove ctxt (Option.map to_versioned value)\n end\n\n module Last_cemented_commitment =\n Indexed_context.Make_carbonated_map\n (Registered)\n (struct\n let name = [\"last_cemented_commitment\"]\n end)\n (struct\n type t = Sc_rollup_commitment_repr.Hash.t\n\n let encoding = Sc_rollup_commitment_repr.Hash.encoding\n end)\n\n module Staker_index_counter =\n Make_single_data_storage (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"staker_index_counter\"]\n end)\n (Sc_rollup_staker_index_repr)\n\n module Staker_index =\n Make_indexed_carbonated_data_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"staker_index\"]\n end))\n (Public_key_hash_index)\n (Sc_rollup_staker_index_repr)\n\n module Stakers =\n Make_indexed_carbonated_data_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"stakers\"]\n end))\n (Make_index (Sc_rollup_staker_index_repr.Index))\n (Raw_level_repr)\n\n module Commitments_versioned =\n Make_indexed_carbonated_data_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"commitments\"]\n end))\n (Make_index (Sc_rollup_commitment_repr.Hash))\n (struct\n type t = Sc_rollup_commitment_repr.versioned\n\n let encoding = Sc_rollup_commitment_repr.versioned_encoding\n end)\n\n module Commitments = struct\n include Commitments_versioned\n include Make_versioned (Sc_rollup_commitment_repr) (Commitments_versioned)\n end\n\n module Commitment_indexed_context =\n Make_indexed_subcontext\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"commitment_index\"]\n end))\n (Make_index (Sc_rollup_commitment_repr.Hash))\n\n module Commitment_stakers =\n Make_indexed_carbonated_data_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"commitments_stakers\"]\n end))\n (Make_index (Sc_rollup_commitment_repr.Hash))\n (struct\n type t = Sc_rollup_staker_index_repr.t list\n\n let encoding = Data_encoding.list Sc_rollup_staker_index_repr.encoding\n end)\n\n module Commitments_per_inbox_level =\n Make_indexed_carbonated_data_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"commitments_per_inbox_level\"]\n end))\n (Make_index (Raw_level_repr.Index))\n (struct\n type t = Sc_rollup_commitment_repr.Hash.t list\n\n let encoding =\n Data_encoding.list Sc_rollup_commitment_repr.Hash.encoding\n end)\n\n module Commitment_first_publication_level =\n Make_indexed_carbonated_data_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"commitment_first_publication_level\"]\n end))\n (Make_index (Raw_level_repr.Index))\n (Raw_level_repr)\n\n module Commitment_added =\n Make_indexed_carbonated_data_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"commitment_added\"]\n end))\n (Make_index (Sc_rollup_commitment_repr.Hash))\n (Raw_level_repr)\n\n module Game_info_versioned =\n Make_indexed_carbonated_data_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"refutation_game_info\"]\n end))\n (Make_index (Sc_rollup_game_repr.Index))\n (struct\n type t = Sc_rollup_game_repr.versioned\n\n let encoding = Sc_rollup_game_repr.versioned_encoding\n end)\n\n module Game_info = struct\n include Game_info_versioned\n include Make_versioned (Sc_rollup_game_repr) (Game_info_versioned)\n end\n\n module Games_per_staker =\n Make_indexed_subcontext\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"game\"]\n end))\n (Public_key_hash_index)\n\n module Game =\n Make_indexed_carbonated_data_storage\n (Make_subcontext (Registered) (Games_per_staker.Raw_context)\n (struct\n let name = [\"opponents\"]\n end))\n (Public_key_hash_index)\n (struct\n type t = Sc_rollup_game_repr.Index.t\n\n let encoding = Sc_rollup_game_repr.Index.encoding\n end)\n\n module Game_timeout =\n Make_indexed_carbonated_data_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"game_timeout\"]\n end))\n (Make_index (Sc_rollup_game_repr.Index))\n (struct\n type t = Sc_rollup_game_repr.timeout\n\n let encoding = Sc_rollup_game_repr.timeout_encoding\n end)\n\n (** An index used for a SCORU's outbox levels. An outbox level is mapped to\n the index through: [outbox_level % sc_rollup_max_active_outbox_levels].\n That way we keep a limited number of entries. The current value of an\n entry contains the most recently added level that maps to the index. *)\n module Level_index = struct\n type t = int32\n\n let rpc_arg =\n let construct = Int32.to_string in\n let destruct hash =\n Int32.of_string_opt hash\n |> Result.of_option ~error:\"Cannot parse level index\"\n in\n RPC_arg.make\n ~descr:\"The level index for applied outbox message records\"\n ~name:\"level_index\"\n ~construct\n ~destruct\n ()\n\n let encoding =\n Data_encoding.def\n \"level_index\"\n ~title:\"Level index\"\n ~description:\"The level index for applied outbox message records\"\n Data_encoding.int32\n\n let compare = Compare.Int32.compare\n\n let path_length = 1\n\n let to_path c l = Int32.to_string c :: l\n\n let of_path = function [c] -> Int32.of_string_opt c | _ -> None\n end\n\n module Level_index_context =\n Make_indexed_subcontext\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"level_index\"]\n end))\n (Make_index (Level_index))\n\n module Bitset_and_level = struct\n type t = Raw_level_repr.t * Bitset.t\n\n let encoding =\n Data_encoding.(\n obj2\n (req \"level\" Raw_level_repr.encoding)\n (req \"bitset\" Bitset.encoding))\n end\n\n module Applied_outbox_messages =\n Level_index_context.Make_carbonated_map\n (Registered)\n (struct\n let name = [\"applied_outbox_messages\"]\n end)\n (Bitset_and_level)\nend\n\nmodule Dal = struct\n module Raw_context =\n Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"dal\"]\n end)\n\n (* DAL/FIXME https://gitlab.com/tezos/tezos/-/issues/3113\n\n This is only for prototyping. Probably something smarter would be\n to index each header directly. *)\n (* DAL/FIXME: https://gitlab.com/tezos/tezos/-/issues/3684\n\n This storage should be carbonated. *)\n module Slot = struct\n module Slot_context =\n Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"slot\"]\n end)\n\n module Level_context =\n Make_indexed_subcontext\n (Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"level\"]\n end))\n (Make_index (Raw_level_repr.Index))\n\n module Headers =\n Level_context.Make_map\n (Registered)\n (struct\n let name = [\"slot_headers\"]\n end)\n (struct\n type t = Dal_slot_repr.Header.t list\n\n let encoding = Data_encoding.(list Dal_slot_repr.Header.encoding)\n end)\n\n module History =\n Make_single_data_storage (Registered) (Raw_context)\n (struct\n let name = [\"slot_headers_history\"]\n end)\n (struct\n type t = Dal_slot_repr.History.t\n\n let encoding = Dal_slot_repr.History.encoding\n end)\n end\nend\n\nmodule Zk_rollup = struct\n module Indexed_context =\n Make_indexed_subcontext\n (Make_subcontext (Registered) (Raw_context)\n (struct\n let name = [\"zk_rollup\"]\n end))\n (Make_index (Zk_rollup_repr.Index))\n\n module Account :\n Non_iterable_indexed_carbonated_data_storage\n with type t := Raw_context.t\n and type key = Zk_rollup_repr.t\n and type value = Zk_rollup_account_repr.t =\n Indexed_context.Make_carbonated_map\n (Registered)\n (struct\n let name = [\"account\"]\n end)\n (Zk_rollup_account_repr)\n\n module Pending_list =\n Indexed_context.Make_carbonated_map\n (Registered)\n (struct\n let name = [\"pending_list\"]\n end)\n (struct\n type t = Zk_rollup_repr.pending_list\n\n let encoding = Zk_rollup_repr.pending_list_encoding\n end)\n\n module Pending_operation :\n Non_iterable_indexed_carbonated_data_storage\n with type t := Raw_context.t * Zk_rollup_repr.t\n and type key = int64\n and type value = Zk_rollup_operation_repr.t * Ticket_hash_repr.t option =\n Make_indexed_carbonated_data_storage\n (Make_subcontext (Registered) (Indexed_context.Raw_context)\n (struct\n let name = [\"pending_operations\"]\n end))\n (Make_index (struct\n type t = int64\n\n let rpc_arg =\n let construct = Int64.to_string in\n let destruct hash =\n Int64.of_string_opt hash\n |> Result.of_option\n ~error:\"Cannot parse pending operation position\"\n in\n RPC_arg.make\n ~descr:\n \"The position of an operation in a pending operations list\"\n ~name:\"zkru_pending_op_position\"\n ~construct\n ~destruct\n ()\n\n let encoding =\n Data_encoding.def\n \"zkru_pending_op_position\"\n ~title:\"Zkru pending operation position\"\n ~description:\n \"The position of an operation in a pending operations list\"\n Data_encoding.Compact.(make ~tag_size:`Uint8 int64)\n\n let compare = Compare.Int64.compare\n\n let path_length = 1\n\n let to_path c l = Int64.to_string c :: l\n\n let of_path = function [c] -> Int64.of_string_opt c | _ -> None\n end))\n (struct\n type t = Zk_rollup_operation_repr.t * Ticket_hash_repr.t option\n\n let encoding =\n Data_encoding.(\n tup2\n Zk_rollup_operation_repr.encoding\n (option Ticket_hash_repr.encoding))\n end)\nend\n" ;
} ;
{ name = "Ticket_hash_builder" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** [make ctxt ~ticketer ~ty ~contents ~owner] creates a hashed\n representation of the given [ticketer], [ty], [contents] and\n [owner].\n*)\nval make :\n Raw_context.t ->\n ticketer:Script_repr.node ->\n ty:Script_repr.node ->\n contents:Script_repr.node ->\n owner:Script_repr.node ->\n (Ticket_hash_repr.t * Raw_context.t) tzresult\n\nmodule Internal_for_tests : sig\n (** As [make] but do not account for gas consumption *)\n val make_uncarbonated :\n ticketer:Script_repr.node ->\n ty:Script_repr.node ->\n contents:Script_repr.node ->\n owner:Script_repr.node ->\n Ticket_hash_repr.t tzresult\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error += Failed_to_hash_node\n\nlet () =\n register_error_kind\n `Branch\n ~id:\"Failed_to_hash_node\"\n ~title:\"Failed to hash node\"\n ~description:\"Failed to hash node for a key in the ticket-balance table\"\n ~pp:(fun ppf () ->\n Format.fprintf\n ppf\n \"Failed to hash node for a key in the ticket-balance table\")\n Data_encoding.empty\n (function Failed_to_hash_node -> Some () | _ -> None)\n (fun () -> Failed_to_hash_node)\n\nlet hash_bytes_cost bytes =\n let module S = Saturation_repr in\n let ( + ) = S.add in\n let v0 = S.safe_int @@ Bytes.length bytes in\n let ( lsr ) = S.shift_right in\n S.safe_int 200 + (v0 + (v0 lsr 2)) |> Gas_limit_repr.atomic_step_cost\n\nlet hash_of_node ctxt node =\n Raw_context.consume_gas ctxt (Script_repr.strip_locations_cost node)\n >>? fun ctxt ->\n let node = Micheline.strip_locations node in\n Result.of_option\n ~error:(Error_monad.trace_of_error Failed_to_hash_node)\n (Data_encoding.Binary.to_bytes_opt Script_repr.expr_encoding node)\n >>? fun bytes ->\n Raw_context.consume_gas ctxt (hash_bytes_cost bytes) >|? fun ctxt ->\n ( Ticket_hash_repr.of_script_expr_hash @@ Script_expr_hash.hash_bytes [bytes],\n ctxt )\n\nlet hash_of_node_uncarbonated node =\n let node = Micheline.strip_locations node in\n Result.of_option\n ~error:(Error_monad.trace_of_error Failed_to_hash_node)\n (Data_encoding.Binary.to_bytes_opt Script_repr.expr_encoding node)\n >|? fun bytes ->\n Ticket_hash_repr.of_script_expr_hash @@ Script_expr_hash.hash_bytes [bytes]\n\nlet make ctxt ~ticketer ~ty ~contents ~owner =\n hash_of_node ctxt\n @@ Micheline.Seq (Micheline.dummy_location, [ticketer; ty; contents; owner])\n\nlet make_uncarbonated ~ticketer ~ty ~contents ~owner =\n hash_of_node_uncarbonated\n @@ Micheline.Seq (Micheline.dummy_location, [ticketer; ty; contents; owner])\n\nmodule Internal_for_tests = struct\n let make_uncarbonated = make_uncarbonated\nend\n" ;
} ;
{ name = "Constants_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2021-2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module provides functions to extract the value of protocol parameters\n from the context.\n See {!Constant_repr.parametric} for more details about these values. *)\n\nval preserved_cycles : Raw_context.t -> int\n\nval blocks_per_cycle : Raw_context.t -> int32\n\nval blocks_per_commitment : Raw_context.t -> int32\n\nval nonce_revelation_threshold : Raw_context.t -> int32\n\nval blocks_per_stake_snapshot : Raw_context.t -> int32\n\nval cycles_per_voting_period : Raw_context.t -> int32\n\nval hard_gas_limit_per_operation :\n Raw_context.t -> Gas_limit_repr.Arith.integral\n\nval hard_gas_limit_per_block : Raw_context.t -> Gas_limit_repr.Arith.integral\n\nval cost_per_byte : Raw_context.t -> Tez_repr.t\n\nval hard_storage_limit_per_operation : Raw_context.t -> Z.t\n\nval proof_of_work_threshold : Raw_context.t -> int64\n\nval minimal_stake : Raw_context.t -> Tez_repr.t\n\nval vdf_difficulty : Raw_context.t -> int64\n\nval seed_nonce_revelation_tip : Raw_context.t -> Tez_repr.t\n\nval origination_size : Raw_context.t -> int\n\nval baking_reward_fixed_portion : Raw_context.t -> Tez_repr.t\n\nval baking_reward_bonus_per_slot : Raw_context.t -> Tez_repr.t\n\nval endorsing_reward_per_slot : Raw_context.t -> Tez_repr.t\n\nval quorum_min : Raw_context.t -> int32\n\nval quorum_max : Raw_context.t -> int32\n\nval min_proposal_quorum : Raw_context.t -> int32\n\nval liquidity_baking_subsidy : Raw_context.t -> Tez_repr.t\n\nval liquidity_baking_toggle_ema_threshold : Raw_context.t -> int32\n\nval parametric : Raw_context.t -> Constants_parametric_repr.t\n\nval tx_rollup : Raw_context.t -> Constants_parametric_repr.tx_rollup\n\nval sc_rollup : Raw_context.t -> Constants_parametric_repr.sc_rollup\n\nval consensus_committee_size : Raw_context.t -> int\n\nval consensus_threshold : Raw_context.t -> int\n\nval minimal_participation_ratio : Raw_context.t -> Ratio_repr.t\n\nval max_slashing_period : Raw_context.t -> int\n\nval frozen_deposits_percentage : Raw_context.t -> int\n\nval double_baking_punishment : Raw_context.t -> Tez_repr.t\n\nval tx_rollup_enable : Raw_context.t -> bool\n\nval tx_rollup_origination_size : Raw_context.t -> int\n\nval tx_rollup_hard_size_limit_per_inbox : Raw_context.t -> int\n\nval tx_rollup_hard_size_limit_per_message : Raw_context.t -> int\n\nval tx_rollup_max_withdrawals_per_batch : Raw_context.t -> int\n\nval tx_rollup_commitment_bond : Raw_context.t -> Tez_repr.t\n\nval tx_rollup_finality_period : Raw_context.t -> int\n\nval tx_rollup_withdraw_period : Raw_context.t -> int\n\nval tx_rollup_max_inboxes_count : Raw_context.t -> int\n\nval tx_rollup_max_messages_per_inbox : Raw_context.t -> int\n\nval tx_rollup_max_commitments_count : Raw_context.t -> int\n\nval tx_rollup_cost_per_byte_ema_factor : Raw_context.t -> int\n\nval tx_rollup_max_ticket_payload_size : Raw_context.t -> int\n\nval tx_rollup_rejection_max_proof_size : Raw_context.t -> int\n\nval tx_rollup_sunset_level : Raw_context.t -> int32\n\nval ratio_of_frozen_deposits_slashed_per_double_endorsement :\n Raw_context.t -> Ratio_repr.t\n\nval testnet_dictator : Raw_context.t -> Signature.Public_key_hash.t option\n\nval minimal_block_delay : Raw_context.t -> Period_repr.t\n\nval delay_increment_per_round : Raw_context.t -> Period_repr.t\n\nval sc_rollup_enable : Raw_context.t -> bool\n\nval sc_rollup_arith_pvm_enable : Raw_context.t -> bool\n\nval sc_rollup_origination_size : Raw_context.t -> int\n\nval sc_rollup_challenge_window_in_blocks : Raw_context.t -> int\n\nval sc_rollup_stake_amount : Raw_context.t -> Tez_repr.t\n\nval sc_rollup_commitment_period_in_blocks : Raw_context.t -> int\n\nval sc_rollup_max_lookahead_in_blocks : Raw_context.t -> int32\n\nval sc_rollup_max_active_outbox_levels : Raw_context.t -> int32\n\nval sc_rollup_max_outbox_messages_per_level : Raw_context.t -> int\n\nval sc_rollup_number_of_sections_in_dissection : Raw_context.t -> int\n\nval sc_rollup_max_number_of_parallel_games : Raw_context.t -> int\n\nval max_number_of_stored_cemented_commitments : Raw_context.t -> int\n\nval sc_rollup_timeout_period_in_blocks : Raw_context.t -> int\n\nval dal_number_of_slots : Raw_context.t -> int\n\nval dal_enable : Raw_context.t -> bool\n\nval zk_rollup_enable : Raw_context.t -> bool\n\nval zk_rollup_min_pending_to_process : Raw_context.t -> int\n\nval zk_rollup_origination_size : Raw_context.t -> int\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021-2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nlet preserved_cycles c =\n let constants = Raw_context.constants c in\n constants.preserved_cycles\n\nlet blocks_per_cycle c =\n let constants = Raw_context.constants c in\n constants.blocks_per_cycle\n\nlet blocks_per_commitment c =\n let constants = Raw_context.constants c in\n constants.blocks_per_commitment\n\nlet nonce_revelation_threshold c =\n let constants = Raw_context.constants c in\n constants.nonce_revelation_threshold\n\nlet blocks_per_stake_snapshot c =\n let constants = Raw_context.constants c in\n constants.blocks_per_stake_snapshot\n\nlet cycles_per_voting_period c =\n let constants = Raw_context.constants c in\n constants.cycles_per_voting_period\n\nlet hard_gas_limit_per_operation c =\n let constants = Raw_context.constants c in\n constants.hard_gas_limit_per_operation\n\nlet hard_gas_limit_per_block c =\n let constants = Raw_context.constants c in\n constants.hard_gas_limit_per_block\n\nlet cost_per_byte c =\n let constants = Raw_context.constants c in\n constants.cost_per_byte\n\nlet hard_storage_limit_per_operation c =\n let constants = Raw_context.constants c in\n constants.hard_storage_limit_per_operation\n\nlet proof_of_work_threshold c =\n let constants = Raw_context.constants c in\n constants.proof_of_work_threshold\n\nlet minimal_stake c =\n let constants = Raw_context.constants c in\n constants.minimal_stake\n\nlet vdf_difficulty c =\n let constants = Raw_context.constants c in\n constants.vdf_difficulty\n\nlet seed_nonce_revelation_tip c =\n let constants = Raw_context.constants c in\n constants.seed_nonce_revelation_tip\n\nlet origination_size c =\n let constants = Raw_context.constants c in\n constants.origination_size\n\nlet baking_reward_fixed_portion c =\n let constants = Raw_context.constants c in\n constants.baking_reward_fixed_portion\n\nlet baking_reward_bonus_per_slot c =\n let constants = Raw_context.constants c in\n constants.baking_reward_bonus_per_slot\n\nlet endorsing_reward_per_slot c =\n let constants = Raw_context.constants c in\n constants.endorsing_reward_per_slot\n\nlet quorum_min c =\n let constants = Raw_context.constants c in\n constants.quorum_min\n\nlet quorum_max c =\n let constants = Raw_context.constants c in\n constants.quorum_max\n\nlet min_proposal_quorum c =\n let constants = Raw_context.constants c in\n constants.min_proposal_quorum\n\nlet liquidity_baking_subsidy c =\n let constants = Raw_context.constants c in\n constants.liquidity_baking_subsidy\n\nlet liquidity_baking_toggle_ema_threshold c =\n let constants = Raw_context.constants c in\n constants.liquidity_baking_toggle_ema_threshold\n\nlet parametric c = Raw_context.constants c\n\nlet tx_rollup c = (Raw_context.constants c).tx_rollup\n\nlet sc_rollup c = (Raw_context.constants c).sc_rollup\n\nlet minimal_block_delay c =\n let constants = Raw_context.constants c in\n constants.minimal_block_delay\n\nlet delay_increment_per_round c =\n let constants = Raw_context.constants c in\n constants.delay_increment_per_round\n\nlet consensus_committee_size c =\n let constants = Raw_context.constants c in\n constants.consensus_committee_size\n\nlet consensus_threshold c =\n let constants = Raw_context.constants c in\n constants.consensus_threshold\n\nlet minimal_participation_ratio c =\n let constants = Raw_context.constants c in\n constants.minimal_participation_ratio\n\nlet max_slashing_period c =\n let constants = Raw_context.constants c in\n constants.max_slashing_period\n\nlet frozen_deposits_percentage c =\n let constants = Raw_context.constants c in\n constants.frozen_deposits_percentage\n\nlet double_baking_punishment c =\n let constants = Raw_context.constants c in\n constants.double_baking_punishment\n\nlet tx_rollup_enable c =\n let tx_rollup = Raw_context.tx_rollup c in\n tx_rollup.enable\n\nlet tx_rollup_sunset_level c =\n let tx_rollup = Raw_context.tx_rollup c in\n tx_rollup.sunset_level\n\nlet tx_rollup_origination_size c =\n let tx_rollup = Raw_context.tx_rollup c in\n tx_rollup.origination_size\n\nlet tx_rollup_hard_size_limit_per_inbox c =\n let tx_rollup = Raw_context.tx_rollup c in\n tx_rollup.hard_size_limit_per_inbox\n\nlet tx_rollup_hard_size_limit_per_message c =\n let tx_rollup = Raw_context.tx_rollup c in\n tx_rollup.hard_size_limit_per_message\n\nlet tx_rollup_max_withdrawals_per_batch c =\n let tx_rollup = Raw_context.tx_rollup c in\n tx_rollup.max_withdrawals_per_batch\n\nlet tx_rollup_commitment_bond c =\n let tx_rollup = Raw_context.tx_rollup c in\n tx_rollup.commitment_bond\n\nlet tx_rollup_finality_period c =\n let tx_rollup = Raw_context.tx_rollup c in\n tx_rollup.finality_period\n\nlet tx_rollup_withdraw_period c =\n let tx_rollup = Raw_context.tx_rollup c in\n tx_rollup.withdraw_period\n\nlet tx_rollup_max_inboxes_count c =\n let tx_rollup = Raw_context.tx_rollup c in\n tx_rollup.max_inboxes_count\n\nlet tx_rollup_max_messages_per_inbox c =\n let tx_rollup = Raw_context.tx_rollup c in\n tx_rollup.max_messages_per_inbox\n\nlet tx_rollup_max_commitments_count c =\n let tx_rollup = Raw_context.tx_rollup c in\n tx_rollup.max_commitments_count\n\nlet tx_rollup_cost_per_byte_ema_factor c =\n let tx_rollup = Raw_context.tx_rollup c in\n tx_rollup.cost_per_byte_ema_factor\n\nlet tx_rollup_max_ticket_payload_size c =\n let tx_rollup = Raw_context.tx_rollup c in\n tx_rollup.max_ticket_payload_size\n\nlet tx_rollup_rejection_max_proof_size c =\n let tx_rollup = Raw_context.tx_rollup c in\n tx_rollup.rejection_max_proof_size\n\nlet ratio_of_frozen_deposits_slashed_per_double_endorsement c =\n let constants = Raw_context.constants c in\n constants.ratio_of_frozen_deposits_slashed_per_double_endorsement\n\nlet testnet_dictator c =\n let constants = Raw_context.constants c in\n constants.testnet_dictator\n\nlet sc_rollup_enable c =\n let sc_rollup = Raw_context.sc_rollup c in\n sc_rollup.enable\n\nlet sc_rollup_arith_pvm_enable c =\n let sc_rollup = Raw_context.sc_rollup c in\n sc_rollup.arith_pvm_enable\n\nlet sc_rollup_origination_size c =\n let sc_rollup = Raw_context.sc_rollup c in\n sc_rollup.origination_size\n\nlet sc_rollup_challenge_window_in_blocks c =\n let sc_rollup = Raw_context.sc_rollup c in\n sc_rollup.challenge_window_in_blocks\n\nlet sc_rollup_stake_amount c =\n let sc_rollup = Raw_context.sc_rollup c in\n sc_rollup.stake_amount\n\nlet sc_rollup_commitment_period_in_blocks c =\n let sc_rollup = Raw_context.sc_rollup c in\n sc_rollup.commitment_period_in_blocks\n\nlet sc_rollup_max_lookahead_in_blocks c =\n let sc_rollup = Raw_context.sc_rollup c in\n sc_rollup.max_lookahead_in_blocks\n\nlet sc_rollup_max_active_outbox_levels c =\n let sc_rollup = Raw_context.sc_rollup c in\n sc_rollup.max_active_outbox_levels\n\nlet sc_rollup_max_outbox_messages_per_level c =\n let sc_rollup = Raw_context.sc_rollup c in\n sc_rollup.max_outbox_messages_per_level\n\nlet sc_rollup_number_of_sections_in_dissection c =\n let sc_rollup = Raw_context.sc_rollup c in\n sc_rollup.number_of_sections_in_dissection\n\nlet sc_rollup_timeout_period_in_blocks c =\n let sc_rollup = Raw_context.sc_rollup c in\n sc_rollup.timeout_period_in_blocks\n\nlet sc_rollup_max_number_of_parallel_games c =\n let sc_rollup = Raw_context.sc_rollup c in\n sc_rollup.max_number_of_parallel_games\n\nlet max_number_of_stored_cemented_commitments c =\n let sc_rollup = Raw_context.sc_rollup c in\n sc_rollup.max_number_of_stored_cemented_commitments\n\nlet dal_number_of_slots c =\n let constants = Raw_context.constants c in\n constants.dal.number_of_slots\n\nlet dal_enable c =\n let constants = Raw_context.constants c in\n constants.dal.feature_enable\n\nlet zk_rollup_enable c =\n let zk_rollup = Raw_context.zk_rollup c in\n zk_rollup.enable\n\nlet zk_rollup_min_pending_to_process c =\n let zk_rollup = Raw_context.zk_rollup c in\n zk_rollup.min_pending_to_process\n\nlet zk_rollup_origination_size c =\n let zk_rollup = Raw_context.zk_rollup c in\n zk_rollup.origination_size\n" ;
} ;
{ name = "Tx_rollup_gas" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error += Tx_rollup_negative_input_size\n\n(** A generic helper to hash an input *)\nval hash :\n hash_f:(bytes list -> 'b) ->\n Raw_context.t ->\n 'a Data_encoding.t ->\n 'a ->\n (Raw_context.t * 'b) tzresult\n\n(** [hash_cost size] returns the cost of gas for hashing a buffer of\n [size] bytes.\n\n Raises [Tx_rollup_negative_input_size] iff [size < 0]. *)\nval hash_cost : int -> Gas_limit_repr.cost tzresult\n\nval consume_check_path_inbox_cost : Raw_context.t -> Raw_context.t tzresult\n\nval consume_check_path_commitment_cost : Raw_context.t -> Raw_context.t tzresult\n\n(** [consume_add_message_cost ctxt] consume the gas cost of adding a\n message to an inbox and return the new context. *)\nval consume_add_message_cost : Raw_context.t -> Raw_context.t tzresult\n\nval consume_compact_commitment_cost :\n Raw_context.t -> int -> Raw_context.t tzresult\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error += Tx_rollup_negative_input_size\n\nmodule S = Saturation_repr\n\n(** The model in {!Michelson_v1_gas.N_IBlake2b}, plus the allocation\n of bytes from {!Storage_functor}. *)\nlet hash_cost input_size =\n error_unless Compare.Int.(0 <= input_size) Tx_rollup_negative_input_size\n >>? fun () ->\n let ( + ) = S.add in\n let cost_serialization = Gas_limit_repr.alloc_mbytes_cost input_size in\n let v0 = Saturation_repr.safe_int input_size in\n let cost_N_IBlake2b = S.safe_int 430 + v0 + S.shift_right v0 3 in\n let cost_blake2b = Gas_limit_repr.atomic_step_cost cost_N_IBlake2b in\n ok @@ (cost_serialization + cost_blake2b)\n\n(** Model from {!Ticket_costs.Constants.cost_compare_ticket_hash} since they are\n Blake2B hashes too. *)\nlet compare_blake2b_hash = S.safe_int 10\n\nlet check_path_cost element_size path_depth =\n let ( + ) = S.add in\n error_unless Compare.Int.(0 <= path_depth) Tx_rollup_negative_input_size\n >>? fun () ->\n (* We hash the element *)\n hash_cost element_size >>? fun element_hash_cost ->\n (* At each step of the way, we hash 2 hashes together *)\n hash_cost 64 >>? fun hash_cost ->\n let rec acc_hash_cost acc i =\n if Compare.Int.(i <= 0) then acc else acc_hash_cost (hash_cost + acc) (i - 1)\n in\n\n ok (element_hash_cost + acc_hash_cost compare_blake2b_hash path_depth)\n\nlet consume_check_path_inbox_cost ctxt =\n let count_limit = Constants_storage.tx_rollup_max_messages_per_inbox ctxt in\n let max_depth = Merkle_list.max_depth ~count_limit in\n check_path_cost Tx_rollup_prefixes.message_hash.hash_size max_depth\n >>? fun cost -> Raw_context.consume_gas ctxt cost\n\nlet consume_check_path_commitment_cost ctxt =\n let count_limit = Constants_storage.tx_rollup_max_messages_per_inbox ctxt in\n let max_depth = Merkle_list.max_depth ~count_limit in\n check_path_cost Tx_rollup_prefixes.message_result_hash.hash_size max_depth\n >>? fun cost -> Raw_context.consume_gas ctxt cost\n\n(** As generated by the model [inbox_add_message_codegen] in\n [lib_benchmarks_proto/tx_rollup_benchmarks.ml]. *)\nlet model_inbox_add_message_codegen inbox_length =\n (* We assume that the Merkle_tree implementation computes a tree\n whose depth is logarithmic in the number of leaves. The cost of\n inserting an element in this structure, in the worst case, is the\n cost of hashing the element and hashing the concatenation of two\n elements at each level in the tree, that is:\n\n cost_of_hashing(32 bytes) + log2(inbox_length) *\n inbox_max_length * cost_of_hashing(32 bytes + 32 bytes)\n\n This cost is captured by the following cost function which is\n inferred emperically through the benchmark & model mentioned\n above. *)\n let log2 n = S.safe_int (1 + S.numbits n) in\n S.mul (S.safe_int 445) (log2 (S.safe_int inbox_length))\n\nlet consume_add_message_cost ctxt =\n let max_messages_per_inbox =\n Constants_storage.tx_rollup_max_messages_per_inbox ctxt\n in\n (* as a safe, constant, over-approximation, suppose the inbox is\n the maximum size allowed *)\n let cost = model_inbox_add_message_codegen max_messages_per_inbox in\n Raw_context.consume_gas ctxt cost\n\n(** As generated by the model [model_commitment_full_compact] in\n [lib_benchmarks_proto/tx_rollup_benchmarks.ml]. We add one to\n [inbox_length] so that the cost is never zero. *)\nlet model_commitment_full_compact inbox_length =\n S.mul (S.safe_int 915) (S.safe_int (1 + inbox_length))\n\nlet consume_compact_commitment_cost ctxt inbox_length =\n let cost = model_commitment_full_compact inbox_length in\n Raw_context.consume_gas ctxt cost\n\nlet hash ~hash_f ctxt encoding input =\n match Data_encoding.Binary.to_bytes_opt encoding input with\n | Some buffer ->\n let len = Bytes.length buffer in\n hash_cost len >>? fun cost ->\n Raw_context.consume_gas ctxt cost >>? fun ctxt ->\n ok (ctxt, hash_f [buffer])\n | None ->\n error\n (Tx_rollup_errors_repr.Internal_error\n \"Cannot serialize input to hash function\")\n\nlet () =\n let open Data_encoding in\n (* Tx_rollup_negative_message_size *)\n register_error_kind\n `Permanent\n ~id:\"tx_rollup_negative_input_size\"\n ~title:\n \"The protocol has computed a negative size for the input of a hash \\\n function\"\n ~description:\n \"The protocol has computed a negative size for the input of a hash \\\n function. This is an internal error, and denotes a bug in the protocol \\\n implementation.\"\n unit\n (function Tx_rollup_negative_input_size -> Some () | _ -> None)\n (fun () -> Tx_rollup_negative_input_size)\n" ;
} ;
{ name = "Tx_rollup_hash_builder" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nlet message :\n Raw_context.t ->\n Tx_rollup_message_repr.t ->\n (Raw_context.t * Tx_rollup_message_hash_repr.t) tzresult =\n fun ctxt input ->\n Tx_rollup_gas.hash\n ~hash_f:Tx_rollup_message_hash_repr.hash_bytes\n ctxt\n Tx_rollup_message_repr.encoding\n input\n\nlet message_result :\n Raw_context.t ->\n Tx_rollup_message_result_repr.t ->\n (Raw_context.t * Tx_rollup_message_result_hash_repr.t) tzresult =\n fun ctxt input ->\n Tx_rollup_gas.hash\n ~hash_f:Tx_rollup_message_result_hash_repr.hash_bytes\n ctxt\n Tx_rollup_message_result_repr.encoding\n input\n\nlet compact_commitment :\n Raw_context.t ->\n Tx_rollup_commitment_repr.Compact.t ->\n (Raw_context.t * Tx_rollup_commitment_repr.Hash.t) tzresult =\n fun ctxt input ->\n Tx_rollup_gas.hash\n ~hash_f:Tx_rollup_commitment_repr.Hash.hash_bytes\n ctxt\n Tx_rollup_commitment_repr.Compact.encoding\n input\n\nlet withdraw_list :\n Raw_context.t ->\n Tx_rollup_withdraw_repr.t list ->\n (Raw_context.t * Tx_rollup_withdraw_list_hash_repr.t) tzresult =\n fun ctxt input ->\n Tx_rollup_gas.hash\n ~hash_f:Tx_rollup_withdraw_list_hash_repr.hash_bytes\n ctxt\n (Data_encoding.list Tx_rollup_withdraw_repr.encoding)\n input\n" ;
} ;
{ name = "Level_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nval current : Raw_context.t -> Level_repr.t\n\nval previous : Raw_context.t -> Level_repr.t\n\nval root : Raw_context.t -> Level_repr.t\n\nval from_raw : Raw_context.t -> Raw_level_repr.t -> Level_repr.t\n\n(** Fails with [Negative_level_and_offset_sum] if the sum of the raw_level and the offset is negative. *)\nval from_raw_with_offset :\n Raw_context.t -> offset:int32 -> Raw_level_repr.t -> Level_repr.t tzresult\n\nval pred : Raw_context.t -> Level_repr.t -> Level_repr.t option\n\nval succ : Raw_context.t -> Level_repr.t -> Level_repr.t\n\n(** [i] must be positive *)\nval add : Raw_context.t -> Level_repr.t -> int -> Level_repr.t\n\n(** [sub c level i] returns None if the level is before the first\n level of the Alpha family of protocol, otherwise it returns the\n expected level. [i] must be positive. *)\nval sub : Raw_context.t -> Level_repr.t -> int -> Level_repr.t option\n\nval first_level_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t\n\nval last_level_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t\n\nval levels_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t list\n\nval levels_in_current_cycle :\n Raw_context.t -> ?offset:int32 -> unit -> Level_repr.t list\n\nval levels_with_commitments_in_cycle :\n Raw_context.t -> Cycle_repr.t -> Level_repr.t list\n\nval last_allowed_fork_level : Raw_context.t -> Raw_level_repr.t\n\n(** Returns [Some cycle] if the current level represents the last\n level of [cycle] and [None] if the level is not the last level of a\n cycle. *)\nval dawn_of_a_new_cycle : Raw_context.t -> Cycle_repr.t option\n\n(** Returns [true] if the stake distribution should be snapshot at the current\n level. *)\nval may_snapshot_stake_distribution : Raw_context.t -> bool\n\n(** Returns [true] if RANDAO should be computed at the current level, that is\n if the current level, relative to the cycle's start, equals the nonce\n revelation period cut-off. *)\nval may_compute_randao : Raw_context.t -> bool\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Level_repr\n\nlet from_raw c l =\n let cycle_eras = Raw_context.cycle_eras c in\n Level_repr.level_from_raw ~cycle_eras l\n\nlet from_raw_with_offset c ~offset l : Level_repr.t tzresult =\n let cycle_eras = Raw_context.cycle_eras c in\n Level_repr.level_from_raw_with_offset ~cycle_eras ~offset l\n\nlet root c = Raw_context.cycle_eras c |> Level_repr.root_level\n\nlet succ c (l : Level_repr.t) = from_raw c (Raw_level_repr.succ l.level)\n\nlet pred c (l : Level_repr.t) =\n match Raw_level_repr.pred l.Level_repr.level with\n | None -> None\n | Some l -> Some (from_raw c l)\n\nlet add c (l : Level_repr.t) n = from_raw c (Raw_level_repr.add l.level n)\n\nlet sub c (l : Level_repr.t) n =\n match Raw_level_repr.sub l.level n with\n | None -> None\n | Some raw_level ->\n let cycle_eras = Raw_context.cycle_eras c in\n let root_level = Level_repr.root_level cycle_eras in\n if Raw_level_repr.(raw_level >= root_level.level) then\n Some (from_raw c raw_level)\n else None\n\nlet current ctxt = Raw_context.current_level ctxt\n\nlet previous ctxt =\n let l = current ctxt in\n match pred ctxt l with\n | None -> assert false (* We never validate the Genesis... *)\n | Some p -> p\n\nlet first_level_in_cycle ctxt cycle =\n let cycle_eras = Raw_context.cycle_eras ctxt in\n Level_repr.first_level_in_cycle_from_eras ~cycle_eras cycle\n\nlet last_level_in_cycle ctxt c =\n match pred ctxt (first_level_in_cycle ctxt (Cycle_repr.succ c)) with\n | None -> assert false\n | Some x -> x\n\nlet levels_in_cycle ctxt cycle =\n let first = first_level_in_cycle ctxt cycle in\n let rec loop (n : Level_repr.t) acc =\n if Cycle_repr.(n.cycle = first.cycle) then loop (succ ctxt n) (n :: acc)\n else acc\n in\n loop first []\n\nlet levels_in_current_cycle ctxt ?(offset = 0l) () =\n let current_cycle = Cycle_repr.to_int32 (current ctxt).cycle in\n let cycle = Int32.add current_cycle offset in\n if Compare.Int32.(cycle < 0l) then []\n else\n let cycle = Cycle_repr.of_int32_exn cycle in\n levels_in_cycle ctxt cycle\n\nlet levels_with_commitments_in_cycle ctxt c =\n let first = first_level_in_cycle ctxt c in\n let rec loop (n : Level_repr.t) acc =\n if Cycle_repr.(n.cycle = first.cycle) then\n if n.expected_commitment then loop (succ ctxt n) (n :: acc)\n else loop (succ ctxt n) acc\n else acc\n in\n loop first []\n\nlet last_allowed_fork_level c =\n let level = Raw_context.current_level c in\n let preserved_cycles = Constants_storage.preserved_cycles c in\n match Cycle_repr.sub level.cycle preserved_cycles with\n | None -> Raw_level_repr.root\n | Some cycle -> (first_level_in_cycle c cycle).level\n\nlet last_of_a_cycle ctxt level =\n let cycle_eras = Raw_context.cycle_eras ctxt in\n Level_repr.last_of_cycle ~cycle_eras level\n\nlet dawn_of_a_new_cycle ctxt =\n let level = current ctxt in\n if last_of_a_cycle ctxt level then Some level.cycle else None\n\nlet may_snapshot_stake_distribution ctxt =\n let level = current ctxt in\n let blocks_per_stake_snapshot =\n Constants_storage.blocks_per_stake_snapshot ctxt\n in\n Compare.Int32.equal\n (Int32.rem level.cycle_position blocks_per_stake_snapshot)\n (Int32.pred blocks_per_stake_snapshot)\n\nlet may_compute_randao ctxt =\n let level = current ctxt in\n let nonce_reveal_cutoff = Constants_storage.nonce_revelation_threshold ctxt in\n Compare.Int32.equal level.cycle_position nonce_reveal_cutoff\n" ;
} ;
{ name = "Nonce_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module provides types and functions to manipulate nonces.\n\n A nonce is a byte sequence of fixed length, which is supposed to be random\n and used only once, provided by a block producer and used to generate a\n random seed (see {!module:Seed_repr}). *)\n\ntype t = Seed_repr.nonce\n\ntype nonce = t\n\ntype error +=\n | Too_late_revelation\n | Too_early_revelation\n | Already_revealed_nonce\n | Inconsistent_nonce\n\nval encoding : nonce Data_encoding.t\n\ntype unrevealed = Storage.Seed.unrevealed_nonce = {\n nonce_hash : Nonce_hash.t;\n delegate : Signature.Public_key_hash.t;\n}\n\ntype status = Unrevealed of unrevealed | Revealed of Seed_repr.nonce\n\nval get : Raw_context.t -> Level_repr.t -> status tzresult Lwt.t\n\ntype nonce_presence = No_nonce_expected | Nonce_expected of status\n\nval check : Raw_context.t -> Level_repr.t -> nonce_presence tzresult Lwt.t\n\nval record_hash : Raw_context.t -> unrevealed -> Raw_context.t tzresult Lwt.t\n\n(** Checks that a nonce revelation operation can be safely applied.\n\n @return [Error Too_early_revelation] if the current cycle is the\n cycle 0 or if the previous cycle is lesser than the cycle of the\n input level.\n\n @return [Error Too_late_revelation] if the previous cycle is\n greater than the cycle of the input level. This error is also\n returned if the current level cycle position is greater or equal to\n the nonce revelation threshold.\n\n @return [Error Already_revealed_nonce] if a nonce is already\n revealed in the context for the input level.\n\n @return [Error Inconsistent_nonce] if the hash of the input nonce\n does not correspond to the nonce recover from the context for the\n given level. *)\nval check_unrevealed :\n Raw_context.t -> Level_repr.t -> nonce -> unit tzresult Lwt.t\n\nval reveal :\n Raw_context.t -> Level_repr.t -> nonce -> Raw_context.t tzresult Lwt.t\n\nval of_bytes : bytes -> nonce tzresult\n\nval hash : nonce -> Nonce_hash.t\n\nval check_hash : nonce -> Nonce_hash.t -> bool\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t = Seed_repr.nonce\n\ntype nonce = t\n\nlet encoding = Seed_repr.nonce_encoding\n\ntype error +=\n | Too_late_revelation\n | Too_early_revelation\n | Already_revealed_nonce\n | Inconsistent_nonce\n\nlet () =\n register_error_kind\n `Branch\n ~id:\"nonce.too_late_revelation\"\n ~title:\"Too late nonce revelation\"\n ~description:\"Nonce revelation happens too late\"\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"This nonce cannot be revealed anymore.\")\n Data_encoding.unit\n (function Too_late_revelation -> Some () | _ -> None)\n (fun () -> Too_late_revelation) ;\n register_error_kind\n `Temporary\n ~id:\"nonce.too_early_revelation\"\n ~title:\"Too early nonce revelation\"\n ~description:\"Nonce revelation happens before cycle end\"\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"This nonce should not yet be revealed\")\n Data_encoding.unit\n (function Too_early_revelation -> Some () | _ -> None)\n (fun () -> Too_early_revelation) ;\n register_error_kind\n `Branch\n ~id:\"nonce.already_revealed\"\n ~title:\"Already revealed nonce\"\n ~description:\"Duplicated revelation for a nonce.\"\n ~pp:(fun ppf () -> Format.fprintf ppf \"This nonce was already revealed\")\n Data_encoding.unit\n (function Already_revealed_nonce -> Some () | _ -> None)\n (fun () -> Already_revealed_nonce) ;\n register_error_kind\n `Branch\n ~id:\"nonce.inconsistent\"\n ~title:\"Inconsistent nonce\"\n ~description:\n \"The provided nonce is inconsistent with the committed nonce hash.\"\n ~pp:(fun ppf () ->\n Format.fprintf\n ppf\n \"This nonce revelation is invalid (inconsistent with the committed \\\n hash)\")\n Data_encoding.unit\n (function Inconsistent_nonce -> Some () | _ -> None)\n (fun () -> Inconsistent_nonce)\n\n(* Checks that the level of a revelation is not too early or too late wrt to the\n current context and that a nonce has not been already revealed for that level.\n Also checks that we are not past the nonce revelation period. *)\nlet get_unrevealed ctxt (level : Level_repr.t) =\n let current_level = Level_storage.current ctxt in\n match Cycle_repr.pred current_level.cycle with\n | None -> tzfail Too_early_revelation (* no revelations during cycle 0 *)\n | Some revealed_cycle -> (\n if Cycle_repr.(revealed_cycle < level.Level_repr.cycle) then\n tzfail Too_early_revelation\n else if\n Cycle_repr.(level.Level_repr.cycle < revealed_cycle)\n || Compare.Int32.(\n current_level.cycle_position\n >= Constants_storage.nonce_revelation_threshold ctxt)\n then tzfail Too_late_revelation\n else\n Storage.Seed.Nonce.get ctxt level >>=? function\n | Revealed _ -> tzfail Already_revealed_nonce\n | Unrevealed status -> return status)\n\nlet record_hash ctxt unrevealed =\n let level = Level_storage.current ctxt in\n Storage.Seed.Nonce.init ctxt level (Unrevealed unrevealed)\n\nlet check_unrevealed ctxt (level : Level_repr.t) nonce =\n get_unrevealed ctxt level >>=? fun unrevealed ->\n fail_unless\n (Seed_repr.check_hash nonce unrevealed.nonce_hash)\n Inconsistent_nonce\n\nlet reveal ctxt level nonce =\n Storage.Seed.Nonce.update ctxt level (Revealed nonce)\n\ntype unrevealed = Storage.Seed.unrevealed_nonce = {\n nonce_hash : Nonce_hash.t;\n delegate : Signature.Public_key_hash.t;\n}\n\ntype status = Storage.Seed.nonce_status =\n | Unrevealed of unrevealed\n | Revealed of Seed_repr.nonce\n\nlet get = Storage.Seed.Nonce.get\n\ntype nonce_presence = No_nonce_expected | Nonce_expected of status\n\nlet check ctxt level =\n Storage.Seed.Nonce.find ctxt level >>=? function\n | None -> return No_nonce_expected\n | Some status -> return (Nonce_expected status)\n\nlet of_bytes = Seed_repr.make_nonce\n\nlet hash = Seed_repr.hash\n\nlet check_hash = Seed_repr.check_hash\n" ;
} ;
{ name = "Seed_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This modules handles the storage of random nonce seeds.\n\n This module is responsible for maintaining the table\n {!Storage.Seed.For_cycle}. *)\n\ntype seed_computation_status =\n | Nonce_revelation_stage\n | Vdf_revelation_stage of {\n seed_discriminant : Seed_repr.seed;\n seed_challenge : Seed_repr.seed;\n }\n | Computation_finished\n\ntype error +=\n | (* `Permanent *)\n Unknown of {\n oldest : Cycle_repr.t;\n cycle : Cycle_repr.t;\n latest : Cycle_repr.t;\n }\n | Already_accepted\n | Unverified_vdf\n | Too_early_revelation\n\n(** Generates the first [preserved_cycles+2] seeds for which\n there are no nonces. *)\nval init :\n ?initial_seed:State_hash.t -> Raw_context.t -> Raw_context.t tzresult Lwt.t\n\n(** Verifies if a VDF (result, proof) is valid.\n\n @return [Error Too_early_revelation] if the nonce revelation\n threshold is greater than the current level cycle position.\n\n @return [Error Already_accepted] if a VDF seed has already been\n recorded.\n\n @return [Error Unverified_vdf] if the {!Seed_repr.vdf_solution} is\n not verified. *)\nval check_vdf : Raw_context.t -> Seed_repr.vdf_solution -> unit tzresult Lwt.t\n\n(** Updates the seed with a function of the VDF result. *)\nval update_seed :\n Raw_context.t -> Seed_repr.vdf_solution -> Raw_context.t tzresult Lwt.t\n\n(** Returns the seed associated with the given cycle. Returns a generic storage\n error when the seed is not available. *)\nval raw_for_cycle :\n Raw_context.t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t\n\n(** Returns the seed associated with the given cycle. Returns the {!Unknown}\n error when the seed is not available. *)\nval for_cycle : Raw_context.t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t\n\n(** Computes RANDAO output for cycle #(current_cycle + preserved + 1) *)\nval compute_randao : Raw_context.t -> Raw_context.t tzresult Lwt.t\n\n(** Must be run at the end of the cycle, resets the VDF state and returns\n unrevealed nonces to know which party has to forfeit its endorsing\n rewards for that cycle. *)\nval cycle_end :\n Raw_context.t ->\n Cycle_repr.t ->\n (Raw_context.t * Nonce_storage.unrevealed list) tzresult Lwt.t\n\n(** Return the random seed computation status, that is whether the VDF\n computation period has started, and if so the information needed, or if it has\n finished for the current cycle. *)\nval get_seed_computation_status :\n Raw_context.t -> seed_computation_status tzresult Lwt.t\n\n(** Removes the seed associated with the given cycle from the storage. It\n assumes the seed exists. If it does not it returns a generic storage error. *)\nval remove_for_cycle :\n Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Lwt_result_syntax\n\ntype seed_computation_status =\n | Nonce_revelation_stage\n | Vdf_revelation_stage of {\n seed_discriminant : Seed_repr.seed;\n seed_challenge : Seed_repr.seed;\n }\n | Computation_finished\n\ntype error +=\n | (* `Permanent *)\n Unknown of {\n oldest : Cycle_repr.t;\n cycle : Cycle_repr.t;\n latest : Cycle_repr.t;\n }\n | Already_accepted\n | Unverified_vdf\n | Too_early_revelation\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"seed.unknown_seed\"\n ~title:\"Unknown seed\"\n ~description:\"The requested seed is not available\"\n ~pp:(fun ppf (oldest, cycle, latest) ->\n if Cycle_repr.(cycle < oldest) then\n Format.fprintf\n ppf\n \"The seed for cycle %a has been cleared from the context (oldest \\\n known seed is for cycle %a)\"\n Cycle_repr.pp\n cycle\n Cycle_repr.pp\n oldest\n else\n Format.fprintf\n ppf\n \"The seed for cycle %a has not been computed yet (latest known seed \\\n is for cycle %a)\"\n Cycle_repr.pp\n cycle\n Cycle_repr.pp\n latest)\n Data_encoding.(\n obj3\n (req \"oldest\" Cycle_repr.encoding)\n (req \"requested\" Cycle_repr.encoding)\n (req \"latest\" Cycle_repr.encoding))\n (function\n | Unknown {oldest; cycle; latest} -> Some (oldest, cycle, latest)\n | _ -> None)\n (fun (oldest, cycle, latest) -> Unknown {oldest; cycle; latest}) ;\n register_error_kind\n `Temporary\n ~id:\"vdf.too_early_revelation\"\n ~title:\"Too early VDF revelation\"\n ~description:\"VDF revelation before the end of the nonce revelation period\"\n Data_encoding.unit\n (function Too_early_revelation -> Some () | _ -> None)\n (fun () -> Too_early_revelation) ;\n register_error_kind\n `Branch\n ~id:\"vdf.unverified_result\"\n ~title:\"Unverified VDF\"\n ~description:\"VDF verification failed\"\n ~pp:(fun ppf () ->\n Format.fprintf\n ppf\n \"A correct VDF result and Wesolowski's proof are expected\")\n Data_encoding.unit\n (function Unverified_vdf -> Some () | _ -> None)\n (fun () -> Unverified_vdf) ;\n register_error_kind\n `Branch\n ~id:\"vdf.previously_revealed\"\n ~title:\"Previously revealed VDF\"\n ~description:\"Duplicate VDF revelation in cycle\"\n Data_encoding.unit\n (function Already_accepted -> Some () | _ -> None)\n (fun () -> Already_accepted)\n\nlet purge_nonces_and_get_unrevealed ctxt ~cycle =\n let levels = Level_storage.levels_with_commitments_in_cycle ctxt cycle in\n let combine (c, unrevealed) level =\n Storage.Seed.Nonce.get c level >>=? function\n | Revealed _ ->\n let+ c = Storage.Seed.Nonce.remove_existing c level in\n (c, unrevealed)\n | Unrevealed u ->\n let+ c = Storage.Seed.Nonce.remove_existing c level in\n (c, u :: unrevealed)\n in\n List.fold_left_es combine (ctxt, []) levels\n\nlet compute_randao ctxt =\n let current_cycle = (Level_storage.current ctxt).cycle in\n let preserved = Constants_storage.preserved_cycles ctxt in\n let cycle_computed = Cycle_repr.add current_cycle (preserved + 1) in\n let*! seed_computed = Storage.Seed.For_cycle.mem ctxt cycle_computed in\n (* Check if seed has already been computed, and not in cycle 0. *)\n match Cycle_repr.(pred current_cycle, pred cycle_computed) with\n | Some prev_cycle, Some prev_cycle_computed when not seed_computed ->\n (* Retrieve the levels with nonce commitments in the previous cycle. *)\n let levels =\n Level_storage.levels_with_commitments_in_cycle ctxt prev_cycle\n in\n (* Retrieve previous preserved seed. *)\n let* prev_seed = Storage.Seed.For_cycle.get ctxt prev_cycle_computed in\n (* Generate preserved seed by updating previous preserved seed with current revealed nonces. *)\n let combine (c, random_seed) level =\n Storage.Seed.Nonce.get c level >>=? function\n | Revealed nonce -> return (c, Seed_repr.update_seed random_seed nonce)\n | Unrevealed _ -> return (c, random_seed)\n in\n let seed = Seed_repr.deterministic_seed prev_seed in\n let* c, seed = List.fold_left_es combine (ctxt, seed) levels in\n Storage.Seed.For_cycle.init c cycle_computed seed\n | _, _ -> return ctxt\n\nlet get_seed_computation_status ctxt =\n let current_level = Level_storage.current ctxt in\n let current_cycle = current_level.cycle in\n let nonce_revelation_threshold =\n Constants_storage.nonce_revelation_threshold ctxt\n in\n if Compare.Int32.(current_level.cycle_position < nonce_revelation_threshold)\n then return Nonce_revelation_stage\n else\n let* status = Storage.Seed.get_status ctxt in\n match status with\n | RANDAO_seed ->\n let preserved = Constants_storage.preserved_cycles ctxt in\n let cycle_computed = Cycle_repr.add current_cycle (preserved + 1) in\n let previous_cycle = Cycle_repr.add current_cycle preserved in\n let* seed_discriminant =\n Storage.Seed.For_cycle.get ctxt previous_cycle\n in\n let* seed_challenge = Storage.Seed.For_cycle.get ctxt cycle_computed in\n return (Vdf_revelation_stage {seed_discriminant; seed_challenge})\n | VDF_seed -> return Computation_finished\n\nlet check_vdf ctxt vdf_solution =\n let* r = get_seed_computation_status ctxt in\n let*? seed_discriminant, seed_challenge =\n match r with\n | Computation_finished -> error Already_accepted\n | Nonce_revelation_stage -> error Too_early_revelation\n | Vdf_revelation_stage {seed_discriminant; seed_challenge} ->\n ok (seed_discriminant, seed_challenge)\n in\n (* To avoid recomputing the discriminant and challenge for every (potentially\n * invalid) submission in a cycle, we compute them once and store them *)\n let* stored = Storage.Seed.VDF_setup.find ctxt in\n let* ctxt, setup =\n match stored with\n | None ->\n let setup =\n Seed_repr.generate_vdf_setup ~seed_discriminant ~seed_challenge\n in\n let*! ctxt = Storage.Seed.VDF_setup.add ctxt setup in\n return (ctxt, setup)\n | Some setup -> return (ctxt, setup)\n in\n let*? () =\n error_unless\n (Option.value\n ~default:false\n (Seed_repr.verify\n setup\n (Constants_storage.vdf_difficulty ctxt)\n vdf_solution))\n Unverified_vdf\n in\n return ()\n\nlet update_seed ctxt vdf_solution =\n let open Lwt_result_syntax in\n (* compute and update seed and change seed status from RANDAO to\n VDF *)\n let current_cycle = (Level_storage.current ctxt).cycle in\n let preserved = Constants_storage.preserved_cycles ctxt in\n let cycle_computed = Cycle_repr.add current_cycle (preserved + 1) in\n let* seed_challenge = Storage.Seed.For_cycle.get ctxt cycle_computed in\n let new_seed = Seed_repr.vdf_to_seed seed_challenge vdf_solution in\n Storage.Seed.For_cycle.update ctxt cycle_computed new_seed Seed_repr.VDF_seed\n\nlet raw_for_cycle = Storage.Seed.For_cycle.get\n\nlet for_cycle ctxt cycle =\n let preserved = Constants_storage.preserved_cycles ctxt in\n let max_slashing_period = Constants_storage.max_slashing_period ctxt in\n let current_cycle = (Level_storage.current ctxt).cycle in\n let latest =\n if Cycle_repr.(current_cycle = root) then\n Cycle_repr.add current_cycle (preserved + 1)\n else Cycle_repr.add current_cycle preserved\n in\n let oldest =\n match Cycle_repr.sub current_cycle (max_slashing_period - 1) with\n | None -> Cycle_repr.root\n | Some oldest -> oldest\n in\n let*? () =\n error_unless\n Cycle_repr.(oldest <= cycle && cycle <= latest)\n (Unknown {oldest; cycle; latest})\n in\n Storage.Seed.For_cycle.get ctxt cycle\n\nlet init ?initial_seed ctxt =\n let preserved = Constants_storage.preserved_cycles ctxt in\n let* ctxt = Storage.Seed_status.init ctxt Seed_repr.RANDAO_seed in\n List.fold_left_es\n (fun (c, ctxt) seed ->\n let cycle = Cycle_repr.of_int32_exn (Int32.of_int c) in\n let+ ctxt = Storage.Seed.For_cycle.init ctxt cycle seed in\n (c + 1, ctxt))\n (0, ctxt)\n (Seed_repr.initial_seeds ?initial_seed (preserved + 2))\n >|=? snd\n\nlet cycle_end ctxt last_cycle =\n let*! ctxt = Storage.Seed.VDF_setup.remove ctxt in\n (* NB: the clearing of past seeds is done elsewhere by the caller *)\n match Cycle_repr.pred last_cycle with\n | None -> return (ctxt, [])\n | Some previous_cycle ->\n (* cycle with revelations *)\n purge_nonces_and_get_unrevealed ctxt ~cycle:previous_cycle\n\nlet remove_for_cycle = Storage.Seed.For_cycle.remove_existing\n" ;
} ;
{ name = "Contract_manager_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error +=\n | (* `Branch *) Unrevealed_manager_key of Contract_repr.t\n | (* `Permanent *)\n Inconsistent_hash of {\n public_key : Signature.Public_key.t;\n expected_hash : Signature.Public_key_hash.t;\n provided_hash : Signature.Public_key_hash.t;\n }\n | (* `Branch *) Previously_revealed_key of Contract_repr.t\n | (* `Branch *) Missing_manager_contract of Contract_repr.t\n\n(** [init ctxt contract manager] associates [manager] to [contract]. This\n function is undefined if [contract] has already a manager associated to it.\n*)\nval init :\n Raw_context.t ->\n Contract_repr.t ->\n Manager_repr.manager_key ->\n Raw_context.t tzresult Lwt.t\n\nval is_manager_key_revealed :\n Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t\n\n(** [check_publick_key pk pkh] asserts that the provided [pk] is\n consistent with the expected public key hash [pkh], otherwise\n fails with an [Inconsistent_hash] error. *)\nval check_public_key :\n Signature.Public_key.t -> Signature.Public_key_hash.t -> unit tzresult\n\n(** [reveal_manager_key ?check_consistency ctxt manager pk] reveals\n the public key [pk] for a given unrevealed [manager]. If the\n optional [?check_consistency] flag is set (and it is set by\n default), it will re-check the same consistency checks than\n [check_public_key] above, otherwise it will assume [manager] is\n indeed the hash of [pk]. It is expected to fail with\n [Previously_revealed_key contract] if [manager] was already\n revealed, and with [Inconsistent_hash] if the (unrevealed) [manager]\n doesn't match the expected hash of the implicit contract associated\n to [pk]. *)\nval reveal_manager_key :\n ?check_consistency:bool ->\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Signature.Public_key.t ->\n Raw_context.t tzresult Lwt.t\n\n(** [get_manager_key ?error ctxt pkh] returns the revealed manager key of the\n contract represented by [pkh]. When [error] is not provided this function\n fails with \"get_manager_key\" error if [pkh] does not have a manager, and\n with [Unrevealed_manager_key] error if the manager has not revealed its key.\n When [error] is provided, the function fails with the provided [error] in\n both cases. *)\nval get_manager_key :\n ?error:error ->\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Signature.Public_key.t tzresult Lwt.t\n\nval remove_existing :\n Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error +=\n | (* `Branch *) Unrevealed_manager_key of Contract_repr.t\n | (* `Permanent *)\n Inconsistent_hash of {\n public_key : Signature.Public_key.t;\n expected_hash : Signature.Public_key_hash.t;\n provided_hash : Signature.Public_key_hash.t;\n }\n | (* `Branch *) Previously_revealed_key of Contract_repr.t\n | (* `Branch *) Missing_manager_contract of Contract_repr.t\n\nlet () =\n register_error_kind\n `Branch\n ~id:\"contract.unrevealed_key\"\n ~title:\"Manager operation precedes key revelation\"\n ~description:\n \"One tried to apply a manager operation without revealing the manager \\\n public key\"\n ~pp:(fun ppf s ->\n Format.fprintf\n ppf\n \"Unrevealed manager key for contract %a.\"\n Contract_repr.pp\n s)\n Data_encoding.(obj1 (req \"contract\" Contract_repr.encoding))\n (function Unrevealed_manager_key s -> Some s | _ -> None)\n (fun s -> Unrevealed_manager_key s) ;\n register_error_kind\n `Permanent\n ~id:\"contract.manager.inconsistent_hash\"\n ~title:\"Inconsistent public key hash\"\n ~description:\n \"A revealed manager public key is inconsistent with the announced hash\"\n ~pp:(fun ppf (k, eh, ph) ->\n Format.fprintf\n ppf\n \"The hash of the manager public key %s is not %a as announced but %a\"\n (Signature.Public_key.to_b58check k)\n Signature.Public_key_hash.pp\n ph\n Signature.Public_key_hash.pp\n eh)\n Data_encoding.(\n obj3\n (req \"public_key\" Signature.Public_key.encoding)\n (req \"expected_hash\" Signature.Public_key_hash.encoding)\n (req \"provided_hash\" Signature.Public_key_hash.encoding))\n (function\n | Inconsistent_hash {public_key; expected_hash; provided_hash} ->\n Some (public_key, expected_hash, provided_hash)\n | _ -> None)\n (fun (public_key, expected_hash, provided_hash) ->\n Inconsistent_hash {public_key; expected_hash; provided_hash}) ;\n register_error_kind\n `Branch\n ~id:\"contract.previously_revealed_key\"\n ~title:\"Manager operation already revealed\"\n ~description:\"One tried to reveal twice a manager public key\"\n ~pp:(fun ppf s ->\n Format.fprintf\n ppf\n \"Previously revealed manager key for contract %a.\"\n Contract_repr.pp\n s)\n Data_encoding.(obj1 (req \"contract\" Contract_repr.encoding))\n (function Previously_revealed_key s -> Some s | _ -> None)\n (fun s -> Previously_revealed_key s) ;\n register_error_kind\n `Branch\n ~id:\"contract.missing_manager_contract\"\n ~title:\"Missing manager contract\"\n ~description:\"The manager contract is missing from the storage\"\n ~pp:(fun ppf s ->\n Format.fprintf\n ppf\n \"The contract %a is missing from the storage.\"\n Contract_repr.pp\n s)\n Data_encoding.(obj1 (req \"contract\" Contract_repr.encoding))\n (function Missing_manager_contract s -> Some s | _ -> None)\n (fun s -> Missing_manager_contract s)\n\nlet init = Storage.Contract.Manager.init\n\nlet is_manager_key_revealed c manager =\n let contract = Contract_repr.Implicit manager in\n Storage.Contract.Manager.find c contract >>=? function\n | None -> return_false\n | Some (Manager_repr.Hash _) -> return_false\n | Some (Manager_repr.Public_key _) -> return_true\n\nlet check_public_key public_key expected_hash =\n let provided_hash = Signature.Public_key.hash public_key in\n error_unless\n (Signature.Public_key_hash.equal provided_hash expected_hash)\n (Inconsistent_hash {public_key; expected_hash; provided_hash})\n\nlet reveal_manager_key ?(check_consistency = true) c manager public_key =\n let contract = Contract_repr.Implicit manager in\n Storage.Contract.Manager.get c contract >>=? function\n | Public_key _ -> tzfail (Previously_revealed_key contract)\n | Hash expected_hash ->\n (* Ensure that the manager is equal to the retrieved hash. *)\n error_unless\n (Signature.Public_key_hash.equal manager expected_hash)\n (Inconsistent_hash {public_key; expected_hash; provided_hash = manager})\n >>?= fun () ->\n (* TODO tezos/tezos#3078\n\n We keep the consistency check and the optional argument to\n preserve the semantics of reveal_manager_key prior to\n tezos/tezos!5182, when called outside the scope of\n [apply_operation].\n\n Inside appply.ml, it is used with\n ?check_consistency=false. Ultimately this parameter should go\n away, and the split check_publick_key / reveal_manager_key\n pattern has to be exported to usage outside apply.ml *)\n when_ check_consistency (fun () ->\n Lwt.return @@ check_public_key public_key expected_hash)\n >>=? fun () ->\n let pk = Manager_repr.Public_key public_key in\n Storage.Contract.Manager.update c contract pk\n\nlet get_manager_key ?error ctxt pkh =\n let contract = Contract_repr.Implicit pkh in\n Storage.Contract.Manager.find ctxt contract >>=? function\n | None -> (\n match error with\n | None -> tzfail (Missing_manager_contract contract)\n | Some error -> tzfail error)\n | Some (Manager_repr.Hash _) -> (\n match error with\n | None -> tzfail (Unrevealed_manager_key contract)\n | Some error -> tzfail error)\n | Some (Manager_repr.Public_key pk) -> return pk\n\nlet remove_existing = Storage.Contract.Manager.remove_existing\n" ;
} ;
{ name = "Delegate_activation_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module deals with delegates' activity. Typically, the provided\n functions can be used to deactivate a delegate that has not shown activity\n for a certain number of cycles, and to reactivate it when appropriate.\n\n This module is responsible for maintaining the following tables:\n - {!Storage.Contract.Inactive_delegate}\n - {!Storage.Contract.Delegate_last_cycle_before_deactivation} *)\n\nval is_inactive :\n Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t\n\n(** [last_cycle_before_deactivation ctxt delegate] is the cycle at which\n the delegate is scheduled to become inactive. *)\nval last_cycle_before_deactivation :\n Raw_context.t -> Signature.Public_key_hash.t -> Cycle_repr.t tzresult Lwt.t\n\n(** [set_inactive context delegate] adds [delegate] to the set of inactive\n contracts. *)\nval set_inactive :\n Raw_context.t -> Signature.Public_key_hash.t -> Raw_context.t Lwt.t\n\n(** [set_active ctxt delegate] returns a pair [(new_ctxt, is_inactive)] where:\n - [new_ctxt] is a new context, updated from [ctxt], where the [delegate]'s\n last active cycle has been updated\n - [is_inactive] represents the state of [delegate], prior to the update.\n *)\nval set_active :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n (Raw_context.t * bool) tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nlet is_inactive ctxt delegate =\n Storage.Contract.Inactive_delegate.mem ctxt (Contract_repr.Implicit delegate)\n >>= fun inactive ->\n if inactive then return inactive\n else\n Storage.Contract.Delegate_last_cycle_before_deactivation.find\n ctxt\n (Contract_repr.Implicit delegate)\n >|=? function\n | Some last_active_cycle ->\n let ({Level_repr.cycle = current_cycle; _} : Level_repr.t) =\n Raw_context.current_level ctxt\n in\n Cycle_repr.(last_active_cycle < current_cycle)\n | None ->\n (* This case is only when called from `set_active`, when creating\n a contract. *)\n false\n\nlet last_cycle_before_deactivation ctxt delegate =\n let contract = Contract_repr.Implicit delegate in\n Storage.Contract.Delegate_last_cycle_before_deactivation.get ctxt contract\n\nlet set_inactive ctxt delegate =\n Storage.Contract.Inactive_delegate.add ctxt (Contract_repr.Implicit delegate)\n\nlet set_active ctxt delegate =\n is_inactive ctxt delegate >>=? fun inactive ->\n let current_cycle = (Raw_context.current_level ctxt).cycle in\n let preserved_cycles = Constants_storage.preserved_cycles ctxt in\n (* We allow a number of cycles before a delegate is deactivated as follows:\n - if the delegate is active, we give it at least `1 + preserved_cycles`\n after the current cycle before to be deactivated.\n - if the delegate is new or inactive, we give it additionally\n `preserved_cycles` because the delegate needs this number of cycles to\n receive rights, so `1 + 2 * preserved_cycles` in total. *)\n let delegate_contract = Contract_repr.Implicit delegate in\n Storage.Contract.Delegate_last_cycle_before_deactivation.find\n ctxt\n delegate_contract\n >>=? fun current_last_active_cycle ->\n let last_active_cycle =\n match current_last_active_cycle with\n | None -> Cycle_repr.add current_cycle (1 + (2 * preserved_cycles))\n | Some current_last_active_cycle ->\n let delay =\n if inactive then 1 + (2 * preserved_cycles) else 1 + preserved_cycles\n in\n let updated = Cycle_repr.add current_cycle delay in\n Cycle_repr.max current_last_active_cycle updated\n in\n Storage.Contract.Delegate_last_cycle_before_deactivation.add\n ctxt\n delegate_contract\n last_active_cycle\n >>= fun ctxt ->\n if not inactive then return (ctxt, inactive)\n else\n Storage.Contract.Inactive_delegate.remove ctxt delegate_contract\n >>= fun ctxt -> return (ctxt, inactive)\n" ;
} ;
{ name = "Frozen_deposits_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Simple abstraction from low-level storage to handle frozen deposits.\n\n This module is responsible for maintaining the\n {!Storage.Contract.Frozen_deposits} table. *)\n\n(** [init ctxt delegate] returns a new context from [ctxt] where the frozen\n deposits of the implicit contract represented by [delegate] have been initialized to\n {!val:Tez_repr.zero}. *)\nval init :\n Raw_context.t -> Signature.Public_key_hash.t -> Raw_context.t tzresult Lwt.t\n\n(** [allocated ctxt contract] checks whether [contract] has frozen deposits in\n [ctxt]. *)\nval allocated : Raw_context.t -> Contract_repr.t -> bool Lwt.t\n\n(** [get ctxt contract] retrieves the frozen deposits of [contract] in [ctxt]. *)\nval get : Raw_context.t -> Contract_repr.t -> Storage.deposits tzresult Lwt.t\n\n(** [find ctxt contract] retrieves the frozen deposits of [contract] in\n [ctxt], if any. *)\nval find :\n Raw_context.t -> Contract_repr.t -> Storage.deposits option tzresult Lwt.t\n\n(** [credit_only_call_from_token ctxt delegate tez] returns a new context from\n [ctxt] where the amount of frozen deposits for the implicit contract\n represented by [delegate] increases by [tez]. *)\nval credit_only_call_from_token :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Tez_repr.t ->\n Raw_context.t tzresult Lwt.t\n\n(** [spend_only_call_from_token ctxt delegate tez] returns a new context from\n [ctxt] where the amount of frozen deposits for the implicit contract\n represented by [delegate] decreases by [tez].*)\nval spend_only_call_from_token :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Tez_repr.t ->\n Raw_context.t tzresult Lwt.t\n\n(** [update_initial_amount ctxt contract tez] returns a new context from [ctxt]\n where the initial_amount of the frozen deposits for [contract] is set to\n [tez]. *)\nval update_initial_amount :\n Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nlet init ctxt delegate =\n Storage.Contract.Frozen_deposits.init\n ctxt\n (Contract_repr.Implicit delegate)\n {initial_amount = Tez_repr.zero; current_amount = Tez_repr.zero}\n\nlet allocated = Storage.Contract.Frozen_deposits.mem\n\nlet get = Storage.Contract.Frozen_deposits.get\n\nlet find = Storage.Contract.Frozen_deposits.find\n\nlet update_balance ctxt delegate f amount =\n let delegate_contract = Contract_repr.Implicit delegate in\n get ctxt delegate_contract >>=? fun frozen_deposits ->\n f frozen_deposits.current_amount amount >>?= fun new_amount ->\n Storage.Contract.Frozen_deposits.update\n ctxt\n delegate_contract\n {frozen_deposits with current_amount = new_amount}\n\nlet credit_only_call_from_token ctxt delegate amount =\n update_balance ctxt delegate Tez_repr.( +? ) amount\n\nlet spend_only_call_from_token ctxt delegate amount =\n update_balance ctxt delegate Tez_repr.( -? ) amount\n\nlet update_initial_amount ctxt delegate_contract deposits_cap =\n get ctxt delegate_contract >>=? fun frozen_deposits ->\n Storage.Contract.Frozen_deposits.update\n ctxt\n delegate_contract\n {frozen_deposits with initial_amount = deposits_cap}\n" ;
} ;
{ name = "Sapling_storage" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2019-2020 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule type COMMITMENTS = sig\n val init : Raw_context.t -> Storage.Sapling.id -> Raw_context.t Lwt.t\n\n val default_root : Sapling.Hash.t\n\n val get_root :\n Raw_context.t ->\n Storage.Sapling.id ->\n (Raw_context.t * Sapling.Hash.t) tzresult Lwt.t\n\n val add :\n Raw_context.t ->\n Storage.Sapling.id ->\n Sapling.Commitment.t list ->\n int64 ->\n (Raw_context.t * int) tzresult Lwt.t\n\n val get_from :\n Raw_context.t ->\n Storage.Sapling.id ->\n int64 ->\n Sapling.Commitment.t list tzresult Lwt.t\nend\n\nmodule Commitments : COMMITMENTS = struct\n module H = Sapling.Hash\n\n (** Incremental Merkle Tree\n *\n * A tree of height h contains 2^h leaves and h+1 levels of nodes with\n * leaves at level 0 and root at level h.\n *\n * The leaves are commitments and the tree it is treated as always filled\n * with a default value H.uncommitted. This allows to have proofs of\n * membership, or witnesses, of fixed size.\n *\n * All the nodes at the same level of an empty tree have the same hash,\n * which can be computed from the default value of the leaves. This is\n * stored in the [uncommitted] list.\n *\n * Any subtree filled with default values is represented by the Empty\n * constructor and given its height it's possible to compute its hash\n * using the [uncommitted] list.\n *\n * The leaves are indexed by their position [pos], ranging from 0 to\n * (2^h)-1. The encoding of [pos] limits the possible size of the tree.\n * In any case the only valid height for the Sapling library is 32, so even\n * if the library encodes positions as uint64, they never exceed uint32.\n *\n * The tree is incremental in the sense that leaves cannot be modified but\n * only added and exclusively in successive positions.\n *\n * Given that elements are added and retrieved by position, it is possible\n * to use this information to efficiently navigate the tree.\n * Given a tree of height [h] and a position [pos], if pos < pow2 (h-1) only\n * the left subtree needs to be inspected recursively. Otherwise only the\n * right needs to be visited, decreasing [pos] by [pow2 (h-1)].\n *\n * In order to avoid storing the height for each subtree (or worse\n * recomputing it), each function with suffix `_height` expects the height\n * of the tree as parameter. These functions are only for internal use and\n * are later aliased by functions using the default height of a Sapling\n * incremental Merkle tree.\n *\n * Each node of the tree is indexed starting from the root at index 1,\n * followed by its left child at index 2, right child at index 3 and so on\n * until the last leaf at index 2^(depth+1)-1, or in terms of height\n * 2^(32 - height +1) -1.\n * The functions left and right return the index of the left and right child\n * of a node.\n *)\n\n let pow2 h = Int64.(shift_left 1L h)\n\n let max_height = 32\n\n let max_size = pow2 max_height\n\n let assert_node node height =\n assert (\n let first_of_height = pow2 (max_height - height) in\n let first_of_next_height = Int64.shift_left first_of_height 1 in\n Compare.Int64.(node >= first_of_height && node < first_of_next_height))\n\n let assert_height height =\n assert (Compare.Int.(height >= 0 && height <= max_height))\n\n let assert_pos pos height =\n assert (Compare.Int64.(pos >= 0L && pos <= pow2 height))\n\n let default_root = H.uncommitted ~height:max_height\n\n let init = Storage.Sapling.commitments_init\n\n let get_root_height ctx id node height =\n assert_node node height ;\n assert_height height ;\n Storage.Sapling.Commitments.find (ctx, id) node >|=? function\n | ctx, None ->\n let hash = H.uncommitted ~height in\n (ctx, hash)\n | ctx, Some hash -> (ctx, hash)\n\n let left node = Int64.mul node 2L\n\n let right node = Int64.(add (mul node 2L) 1L)\n\n (* Not tail-recursive *)\n let rec split_at n l =\n if Compare.Int64.(n = 0L) then ([], l)\n else\n match l with\n | [] -> ([], l)\n | x :: xs ->\n let l1, l2 = split_at Int64.(pred n) xs in\n (x :: l1, l2)\n\n (* [insert tree height pos cms] inserts the list of commitments\n [cms] in the tree [tree] of height [height] at the next position [pos].\n Returns the context, the size of the added storage, and the hash of the\n node. Not tail-recursive.\n Pre: incremental tree /\\\n size tree + List.length cms <= pow2 height /\\\n pos = size tree /\\\n Post: incremental tree /\\\n to_list (insert tree height pos cms) = to_list t @ cms *)\n let rec insert ctx id node height pos cms =\n assert_node node height ;\n assert_height height ;\n assert_pos pos height ;\n match (height, cms) with\n | _, [] ->\n get_root_height ctx id node height >|=? fun (ctx, h) -> (ctx, 0, h)\n | 0, [cm] ->\n let h = H.of_commitment cm in\n Storage.Sapling.Commitments.init (ctx, id) node h\n >|=? fun (ctx, size) -> (ctx, size, h)\n | _ ->\n let height = height - 1 in\n (if Compare.Int64.(pos < pow2 height) then\n let at = Int64.(sub (pow2 height) pos) in\n let cml, cmr = split_at at cms in\n insert ctx id (left node) height pos cml >>=? fun (ctx, size_l, hl) ->\n insert ctx id (right node) height 0L cmr >|=? fun (ctx, size_r, hr) ->\n (ctx, size_l + size_r, hl, hr)\n else\n get_root_height ctx id (left node) height >>=? fun (ctx, hl) ->\n let pos = Int64.(sub pos (pow2 height)) in\n insert ctx id (right node) height pos cms\n >|=? fun (ctx, size_r, hr) -> (ctx, size_r, hl, hr))\n >>=? fun (ctx, size_children, hl, hr) ->\n let h = H.merkle_hash ~height hl hr in\n Storage.Sapling.Commitments.add (ctx, id) node h\n >|=? fun (ctx, size, _existing) -> (ctx, size + size_children, h)\n\n let rec fold_from_height ctx id node ~pos ~f ~acc height =\n assert_node node height ;\n assert_height height ;\n assert_pos pos height ;\n Storage.Sapling.Commitments.find (ctx, id) node\n (* we don't count gas for this function, it is called only by RPC *)\n >>=?\n function\n | _ctx, None -> return acc\n | _ctx, Some h ->\n if Compare.Int.(height = 0) then return (f acc h)\n else\n let full = pow2 (height - 1) in\n if Compare.Int64.(pos < full) then\n fold_from_height ctx id (left node) ~pos ~f ~acc (height - 1)\n >>=? fun acc ->\n (* Setting pos to 0 folds on the whole right subtree *)\n fold_from_height ctx id (right node) ~pos:0L ~f ~acc (height - 1)\n else\n let pos = Int64.(sub pos full) in\n fold_from_height ctx id (right node) ~pos ~f ~acc (height - 1)\n\n let root_node = 1L\n\n let get_root ctx id = get_root_height ctx id root_node max_height\n\n (* Expects pos to be the next position to insert. Pos is also the number of\n inserted leaves.\n A commitment should always be added together with a corresponding\n ciphertext in the same position.\n [insert] is not tail-recursive so we put a hard limit on the size of the\n list of commitments. The use of [split_at] has O(n logn) complexity that is\n less relevant on a smaller list. *)\n let add ctx id cms pos =\n let l = List.length cms in\n assert (Compare.Int.(l <= 1000)) ;\n let n' = Int64.(add pos (of_int l)) in\n assert (Compare.Int64.(n' <= max_size)) ;\n insert ctx id root_node max_height pos cms >|=? fun (ctx, size, _h) ->\n (ctx, size)\n\n let get_from ctx id pos =\n fold_from_height\n ctx\n id\n root_node\n ~pos\n ~f:(fun acc c -> H.to_commitment c :: acc)\n ~acc:[]\n max_height\n >|=? fun l -> List.rev l\nend\n\nmodule Ciphertexts = struct\n let init ctx id = Storage.Sapling.ciphertexts_init ctx id\n\n (* a ciphertext should always be added together with a corresponding\n commitment in the same position *)\n let add ctx id c pos = Storage.Sapling.Ciphertexts.init (ctx, id) pos c\n\n let get_from ctx id offset =\n let rec aux (ctx, acc) pos =\n Storage.Sapling.Ciphertexts.find (ctx, id) pos >>=? fun (ctx, c) ->\n match c with\n | None -> return (ctx, List.rev acc)\n | Some c -> aux (ctx, c :: acc) (Int64.succ pos)\n in\n aux (ctx, []) offset\nend\n\n(* Collection of nullifiers w/o duplicates, append-only. It has a dual\n implementation with a hash map for constant `mem` and with a ordered set to\n retrieve by position. *)\nmodule Nullifiers = struct\n let init = Storage.Sapling.nullifiers_init\n\n let size ctx id = Storage.Sapling.Nullifiers_size.get (ctx, id)\n\n let mem ctx id nf = Storage.Sapling.Nullifiers_hashed.mem (ctx, id) nf\n\n (* Allows for duplicates as they are already checked by verify_update before\n updating the state.\n Not tail-recursive so we put a hard limit on the size of the\n list of nullifiers. *)\n let add ctx id nfs =\n assert (Compare.Int.(List.compare_length_with nfs 1000 <= 0)) ;\n size ctx id >>=? fun nf_start_pos ->\n List.fold_right_es\n (fun nf (ctx, pos, acc_size) ->\n Storage.Sapling.Nullifiers_hashed.init (ctx, id) nf\n >>=? fun (ctx, size) ->\n Storage.Sapling.Nullifiers_ordered.init (ctx, id) pos nf >|=? fun ctx ->\n (ctx, Int64.succ pos, Z.add acc_size (Z.of_int size)))\n nfs\n (ctx, nf_start_pos, Z.zero)\n >>=? fun (ctx, nf_end_pos, size) ->\n Storage.Sapling.Nullifiers_size.update (ctx, id) nf_end_pos >|=? fun ctx ->\n (ctx, size)\n\n let get_from ctx id offset =\n let rec aux acc pos =\n Storage.Sapling.Nullifiers_ordered.find (ctx, id) pos >>=? function\n | None -> return @@ List.rev acc\n | Some c -> aux (c :: acc) (Int64.succ pos)\n in\n aux [] offset\nend\n\n(** Bounded queue of roots. The full size is initialized with the default\n uncommitted root, that's why roots storage doesn't need to be carbonated.\n A maximum of one new root is added per protocol level.\n If multiple transactions for the same shielded pool are processed during the\n same contract call or several calls in the same block, only the last root\n will be stored.\n This property prevents transactions in the same block from depending on each\n other and guarantees that a transaction will be valid for a least two hours\n (hence the 120 size) after being forged. *)\nmodule Roots = struct\n let size = 120l\n\n (* pos is the index of the last inserted element *)\n\n let get ctx id =\n Storage.Sapling.Roots_pos.get (ctx, id) >>=? fun pos ->\n Storage.Sapling.Roots.get (ctx, id) pos\n\n let init ctx id =\n let rec aux ctx pos =\n if Compare.Int32.(pos < 0l) then return ctx\n else\n Storage.Sapling.Roots.init (ctx, id) pos Commitments.default_root\n >>=? fun ctx -> aux ctx (Int32.pred pos)\n in\n aux ctx (Int32.pred size) >>=? fun ctx ->\n Storage.Sapling.Roots_pos.init (ctx, id) 0l >>=? fun ctx ->\n let level = (Raw_context.current_level ctx).level in\n Storage.Sapling.Roots_level.init (ctx, id) level\n\n let mem ctx id root =\n Storage.Sapling.Roots_pos.get (ctx, id) >>=? fun start_pos ->\n let rec aux pos =\n Storage.Sapling.Roots.get (ctx, id) pos >>=? fun hash ->\n if Compare.Int.(Sapling.Hash.compare hash root = 0) then return true\n else\n let pos = Int32.(pred pos) in\n let pos = if Compare.Int32.(pos < 0l) then Int32.pred size else pos in\n if Compare.Int32.(pos = start_pos) then return false else aux pos\n in\n aux start_pos\n\n (* allows duplicates *)\n let add ctx id root =\n Storage.Sapling.Roots_pos.get (ctx, id) >>=? fun pos ->\n let level = (Raw_context.current_level ctx).level in\n Storage.Sapling.Roots_level.get (ctx, id) >>=? fun stored_level ->\n if Raw_level_repr.(stored_level = level) then\n (* if there is another add during the same level, it will over-write on\n the same position *)\n Storage.Sapling.Roots.add (ctx, id) pos root >|= ok\n else\n (* it's the first add for this level *)\n (* TODO(samoht): why is it using [update] and not [init] then? *)\n Storage.Sapling.Roots_level.update (ctx, id) level >>=? fun ctx ->\n let pos = Int32.rem (Int32.succ pos) size in\n Storage.Sapling.Roots_pos.update (ctx, id) pos >>=? fun ctx ->\n Storage.Sapling.Roots.add (ctx, id) pos root >|= ok\nend\n\n(** This type links the permanent state stored in the context at the specified\n id together with the ephemeral diff managed by the Michelson\n interpreter. After a successful execution the diff can be applied to update\n the state at id. The first time a state is created its id is None, one will\n be assigned after the first application. *)\ntype state = {\n id : Lazy_storage_kind.Sapling_state.Id.t option;\n diff : Sapling_repr.diff;\n memo_size : Sapling_repr.Memo_size.t;\n}\n\nlet empty_diff =\n Sapling_repr.{commitments_and_ciphertexts = []; nullifiers = []}\n\nlet empty_state ?id ~memo_size () = {id; diff = empty_diff; memo_size}\n\n(** Returns a state from an existing id. *)\nlet state_from_id ctxt id =\n Storage.Sapling.Memo_size.get (ctxt, id) >|=? fun memo_size ->\n ({id = Some id; diff = empty_diff; memo_size}, ctxt)\n\nlet rpc_arg = Storage.Sapling.rpc_arg\n\nlet get_memo_size ctx id = Storage.Sapling.Memo_size.get (ctx, id)\n\nlet init ctx id ~memo_size =\n Storage.Sapling.Memo_size.add (ctx, id) memo_size >>= fun ctx ->\n Storage.Sapling.Commitments_size.add (ctx, id) Int64.zero >>= fun ctx ->\n Commitments.init ctx id >>= fun ctx ->\n Nullifiers.init ctx id >>= fun ctx ->\n Roots.init ctx id >>=? fun ctx -> Ciphertexts.init ctx id >|= ok\n\n(* Gas costs for apply_diff. *)\nlet sapling_apply_diff_cost ~inputs ~outputs =\n let open Saturation_repr in\n add\n (safe_int 1_300_000)\n (add\n (scale_fast (mul_safe_of_int_exn 5_000) (safe_int inputs))\n (scale_fast (mul_safe_of_int_exn 55_000) (safe_int outputs)))\n\n(** Applies a diff to a state id stored in the context. Updates Commitments,\n Ciphertexts and Nullifiers using the diff and updates the Roots using the\n new Commitments tree. *)\nlet apply_diff ctx id diff =\n let open Sapling_repr in\n let nb_commitments = List.length diff.commitments_and_ciphertexts in\n let nb_nullifiers = List.length diff.nullifiers in\n let sapling_cost =\n sapling_apply_diff_cost ~inputs:nb_nullifiers ~outputs:nb_commitments\n in\n Raw_context.consume_gas ctx sapling_cost >>?= fun ctx ->\n Storage.Sapling.Commitments_size.get (ctx, id) >>=? fun cm_start_pos ->\n let cms = List.rev_map fst diff.commitments_and_ciphertexts in\n Commitments.add ctx id cms cm_start_pos >>=? fun (ctx, size) ->\n Storage.Sapling.Commitments_size.update\n (ctx, id)\n (Int64.add cm_start_pos (Int64.of_int nb_commitments))\n >>=? fun ctx ->\n List.fold_right_es\n (fun (_cm, cp) (ctx, pos, acc_size) ->\n Ciphertexts.add ctx id cp pos >|=? fun (ctx, size) ->\n (ctx, Int64.succ pos, Z.add acc_size (Z.of_int size)))\n diff.commitments_and_ciphertexts\n (ctx, cm_start_pos, Z.of_int size)\n >>=? fun (ctx, _ct_end_pos, size) ->\n Nullifiers.add ctx id diff.nullifiers >>=? fun (ctx, size_nf) ->\n let size = Z.add size size_nf in\n match diff.commitments_and_ciphertexts with\n | [] ->\n (* avoids adding duplicates to Roots *)\n return (ctx, size)\n | _ :: _ ->\n Commitments.get_root ctx id >>=? fun (ctx, root) ->\n Roots.add ctx id root >|=? fun ctx -> (ctx, size)\n\nlet add {id; diff; memo_size} cm_cipher_list =\n assert (\n List.for_all\n (fun (_cm, cipher) ->\n Compare.Int.(Sapling.Ciphertext.get_memo_size cipher = memo_size))\n cm_cipher_list) ;\n {\n id;\n diff =\n {\n diff with\n commitments_and_ciphertexts =\n List.rev cm_cipher_list @ diff.commitments_and_ciphertexts;\n };\n memo_size;\n }\n\nlet root_mem ctx {id; _} tested_root =\n match id with\n | Some id -> Roots.mem ctx id tested_root\n | None ->\n return\n Compare.Int.(\n Sapling.Hash.compare tested_root Commitments.default_root = 0)\n\n(* to avoid a double spend we need to check the disk AND the diff *)\nlet nullifiers_mem ctx {id; diff; _} nf =\n let exists_in_diff =\n List.exists\n (fun v -> Compare.Int.(Sapling.Nullifier.compare nf v = 0))\n diff.nullifiers\n in\n if exists_in_diff then return (ctx, true)\n else\n match id with\n | None -> return (ctx, false)\n | Some id -> Nullifiers.mem ctx id nf\n\n(* Allows for duplicates as they are already checked by verify_update before\n updating the state. *)\nlet nullifiers_add {id; diff; memo_size} nf =\n {id; diff = {diff with nullifiers = nf :: diff.nullifiers}; memo_size}\n\ntype root = Sapling.Hash.t\n\nlet root_encoding = Sapling.Hash.encoding\n\nlet get_diff ctx id ?(offset_commitment = 0L) ?(offset_nullifier = 0L) () =\n if\n not\n Sapling.Commitment.(\n valid_position offset_commitment && valid_position offset_nullifier)\n then failwith \"Invalid argument.\"\n else\n Commitments.get_from ctx id offset_commitment >>=? fun commitments ->\n Roots.get ctx id >>=? fun root ->\n Nullifiers.get_from ctx id offset_nullifier >>=? fun nullifiers ->\n Ciphertexts.get_from ctx id offset_commitment\n (* we don't count gas for RPCs *)\n >|=? fun (_ctx, ciphertexts) ->\n match List.combine ~when_different_lengths:() commitments ciphertexts with\n | Error () -> failwith \"Invalid argument.\"\n | Ok commitments_and_ciphertexts ->\n (root, Sapling_repr.{commitments_and_ciphertexts; nullifiers})\n" ;
} ;
{ name = "Lazy_storage_diff" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2020 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining 'a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(**\n See [Lazy_storage_kind] for an introduction on lazy storage.\n\n This module defines operations on lazy storage types and diffs.\n*)\n\ntype ('id, 'alloc) init = Existing | Copy of {src : 'id} | Alloc of 'alloc\n\ntype ('id, 'alloc, 'updates) diff =\n | Remove\n | Update of {init : ('id, 'alloc) init; updates : 'updates}\n\n(* Exposing this type is needed only for legacy big map diff. *)\ntype diffs_item = private\n | Item :\n ('i, 'a, 'u) Lazy_storage_kind.t * 'i * ('i, 'a, 'u) diff\n -> diffs_item\n\nval make :\n ('i, 'a, 'u) Lazy_storage_kind.t -> 'i -> ('i, 'a, 'u) diff -> diffs_item\n\ntype diffs = diffs_item list\n\nval diffs_in_memory_size : diffs -> Cache_memory_helpers.nodes_and_size\n\nval encoding : diffs Data_encoding.t\n\n(**\n The returned [Z.t] is the size added by the application of the diffs.\n*)\nval apply : Raw_context.t -> diffs -> (Raw_context.t * Z.t) tzresult Lwt.t\n\nval fresh :\n ('id, _, _) Lazy_storage_kind.t ->\n temporary:bool ->\n Raw_context.t ->\n (Raw_context.t * 'id) tzresult Lwt.t\n\n(**\n Initializes the storage for all lazy storage kind.\n This is useful for genesis only.\n Protocol updates need to initialize new lazy storage kinds.\n*)\nval init : Raw_context.t -> Raw_context.t tzresult Lwt.t\n\nval cleanup_temporaries : Raw_context.t -> Raw_context.t Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2020 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule type Next = sig\n type id\n\n val init : Raw_context.t -> Raw_context.t tzresult Lwt.t\n\n val incr : Raw_context.t -> (Raw_context.t * id) tzresult Lwt.t\nend\n\nmodule type Total_bytes = sig\n type id\n\n val init : Raw_context.t -> id -> Z.t -> Raw_context.t tzresult Lwt.t\n\n val get : Raw_context.t -> id -> Z.t tzresult Lwt.t\n\n val update : Raw_context.t -> id -> Z.t -> Raw_context.t tzresult Lwt.t\nend\n\n(** Operations to be defined on a lazy storage type. *)\nmodule type OPS = sig\n module Id : Lazy_storage_kind.ID\n\n type alloc\n\n type updates\n\n val title : string\n\n val alloc_encoding : alloc Data_encoding.t\n\n val updates_encoding : updates Data_encoding.t\n\n val alloc_in_memory_size : alloc -> Cache_memory_helpers.nodes_and_size\n\n val updates_in_memory_size : updates -> Cache_memory_helpers.nodes_and_size\n\n val bytes_size_for_empty : Z.t\n\n val alloc : Raw_context.t -> id:Id.t -> alloc -> Raw_context.t tzresult Lwt.t\n\n val apply_updates :\n Raw_context.t -> id:Id.t -> updates -> (Raw_context.t * Z.t) tzresult Lwt.t\n\n module Next : Next with type id := Id.t\n\n module Total_bytes : Total_bytes with type id := Id.t\n\n (** Deep copy. *)\n val copy :\n Raw_context.t -> from:Id.t -> to_:Id.t -> Raw_context.t tzresult Lwt.t\n\n (** Deep deletion. *)\n val remove : Raw_context.t -> Id.t -> Raw_context.t Lwt.t\nend\n\nmodule Big_map = struct\n include Lazy_storage_kind.Big_map\n\n let alloc_in_memory_size {key_type; value_type} =\n let open Cache_memory_helpers in\n ret_adding\n (expr_size key_type ++ expr_size value_type)\n (header_size +! (word_size *? 2))\n\n let updates_in_memory_size updates =\n let open Cache_memory_helpers in\n let update_size {key; key_hash = _; value} =\n ret_adding\n (expr_size key ++ option_size_vec expr_size value)\n (header_size +! (word_size *? 3) +? Script_expr_hash.size)\n in\n list_fold_size update_size updates\n\n let bytes_size_for_big_map_key = 65\n\n let bytes_size_for_empty =\n let bytes_size_for_big_map = 33 in\n Z.of_int bytes_size_for_big_map\n\n let alloc ctxt ~id {key_type; value_type} =\n (* Annotations are erased to allow sharing on [Copy]. The types from the\n contract code are used, these ones are only used to make sure they are\n compatible during transmissions between contracts, and only need to be\n compatible, annotations notwithstanding. *)\n let key_type =\n Micheline.strip_locations\n (Script_repr.strip_annotations (Micheline.root key_type))\n in\n let value_type =\n Micheline.strip_locations\n (Script_repr.strip_annotations (Micheline.root value_type))\n in\n Storage.Big_map.Key_type.init ctxt id key_type >>=? fun ctxt ->\n Storage.Big_map.Value_type.init ctxt id value_type\n\n let apply_update ctxt ~id\n {\n key = _key_is_shown_only_on_the_receipt_in_print_big_map_diff;\n key_hash;\n value;\n } =\n match value with\n | None ->\n Storage.Big_map.Contents.remove (ctxt, id) key_hash\n >|=? fun (ctxt, freed, existed) ->\n let freed =\n if existed then freed + bytes_size_for_big_map_key else freed\n in\n (ctxt, Z.of_int ~-freed)\n | Some v ->\n Storage.Big_map.Contents.add (ctxt, id) key_hash v\n >|=? fun (ctxt, size_diff, existed) ->\n let size_diff =\n if existed then size_diff else size_diff + bytes_size_for_big_map_key\n in\n (ctxt, Z.of_int size_diff)\n\n let apply_updates ctxt ~id updates =\n List.fold_left_es\n (fun (ctxt, size) update ->\n apply_update ctxt ~id update >|=? fun (ctxt, added_size) ->\n (ctxt, Z.add size added_size))\n (ctxt, Z.zero)\n updates\n\n include Storage.Big_map\nend\n\ntype ('id, 'alloc, 'updates) ops =\n (module OPS\n with type Id.t = 'id\n and type alloc = 'alloc\n and type updates = 'updates)\n\nmodule Sapling_state = struct\n include Lazy_storage_kind.Sapling_state\n\n let alloc_in_memory_size {memo_size = (_ : int)} =\n let open Cache_memory_helpers in\n (Nodes.zero, header_size +! word_size)\n\n let updates_in_memory_size update =\n (Cache_memory_helpers.Nodes.zero, Sapling_repr.diff_in_memory_size update)\n\n let bytes_size_for_empty = Z.of_int 33\n\n let alloc ctxt ~id {memo_size} = Sapling_storage.init ctxt id ~memo_size\n\n let apply_updates ctxt ~id updates =\n Sapling_storage.apply_diff ctxt id updates\n\n include Storage.Sapling\nend\n\n(*\n To add a new lazy storage kind here, you only need to create a module similar\n to [Big_map] above and add a case to [get_ops] below.\n*)\n\nlet get_ops : type i a u. (i, a, u) Lazy_storage_kind.t -> (i, a, u) ops =\n function\n | Big_map -> (module Big_map)\n | Sapling_state -> (module Sapling_state)\n\ntype ('id, 'alloc) init = Existing | Copy of {src : 'id} | Alloc of 'alloc\n\ntype ('id, 'alloc, 'updates) diff =\n | Remove\n | Update of {init : ('id, 'alloc) init; updates : 'updates}\n\nlet diff_encoding : type i a u. (i, a, u) ops -> (i, a, u) diff Data_encoding.t\n =\n fun (module OPS) ->\n let open Data_encoding in\n union\n [\n case\n (Tag 0)\n ~title:\"update\"\n (obj2\n (req \"action\" (constant \"update\"))\n (req \"updates\" OPS.updates_encoding))\n (function\n | Update {init = Existing; updates} -> Some ((), updates) | _ -> None)\n (fun ((), updates) -> Update {init = Existing; updates});\n case\n (Tag 1)\n ~title:\"remove\"\n (obj1 (req \"action\" (constant \"remove\")))\n (function Remove -> Some () | _ -> None)\n (fun () -> Remove);\n case\n (Tag 2)\n ~title:\"copy\"\n (obj3\n (req \"action\" (constant \"copy\"))\n (req \"source\" OPS.Id.encoding)\n (req \"updates\" OPS.updates_encoding))\n (function\n | Update {init = Copy {src}; updates} -> Some ((), src, updates)\n | _ -> None)\n (fun ((), src, updates) -> Update {init = Copy {src}; updates});\n case\n (Tag 3)\n ~title:\"alloc\"\n (merge_objs\n (obj2\n (req \"action\" (constant \"alloc\"))\n (req \"updates\" OPS.updates_encoding))\n OPS.alloc_encoding)\n (function\n | Update {init = Alloc alloc; updates} -> Some (((), updates), alloc)\n | _ -> None)\n (fun (((), updates), alloc) -> Update {init = Alloc alloc; updates});\n ]\n\nlet init_size :\n type i a u.\n (i, a, u) ops -> (i, a) init -> Cache_memory_helpers.nodes_and_size =\n fun (module OPS) init ->\n let open Cache_memory_helpers in\n match init with\n | Existing -> zero\n | Copy {src = _id_is_a_Z_fitting_in_an_int_for_a_long_time} ->\n (Nodes.zero, header_size +! word_size)\n | Alloc alloc ->\n ret_adding (OPS.alloc_in_memory_size alloc) (header_size +! word_size)\n\nlet updates_size :\n type i a u. (i, a, u) ops -> u -> Cache_memory_helpers.nodes_and_size =\n fun (module OPS) updates -> OPS.updates_in_memory_size updates\n\nlet diff_in_memory_size kind diff =\n let open Cache_memory_helpers in\n match diff with\n | Remove -> zero\n | Update {init; updates} ->\n let ops = get_ops kind in\n ret_adding (init_size ops init ++ updates_size ops updates) h2w\n\n(**\n [apply_updates ctxt ops ~id init] applies the updates [updates] on lazy\n storage [id] on storage context [ctxt] using operations [ops] and returns the\n updated storage context and the added size in bytes (may be negative).\n*)\nlet apply_updates :\n type i a u.\n Raw_context.t ->\n (i, a, u) ops ->\n id:i ->\n u ->\n (Raw_context.t * Z.t) tzresult Lwt.t =\n fun ctxt (module OPS) ~id updates ->\n OPS.apply_updates ctxt ~id updates >>=? fun (ctxt, updates_size) ->\n if Z.(equal updates_size zero) then return (ctxt, updates_size)\n else\n OPS.Total_bytes.get ctxt id >>=? fun size ->\n OPS.Total_bytes.update ctxt id (Z.add size updates_size) >|=? fun ctxt ->\n (ctxt, updates_size)\n\n(**\n [apply_init ctxt ops ~id init] applies the initialization [init] on lazy\n storage [id] on storage context [ctxt] using operations [ops] and returns the\n updated storage context and the added size in bytes (may be negative).\n\n If [id] represents a temporary lazy storage, the added size may be wrong.\n*)\nlet apply_init :\n type i a u.\n Raw_context.t ->\n (i, a, u) ops ->\n id:i ->\n (i, a) init ->\n (Raw_context.t * Z.t) tzresult Lwt.t =\n fun ctxt (module OPS) ~id init ->\n match init with\n | Existing -> return (ctxt, Z.zero)\n | Copy {src} ->\n OPS.copy ctxt ~from:src ~to_:id >>=? fun ctxt ->\n if OPS.Id.is_temp id then return (ctxt, Z.zero)\n else\n OPS.Total_bytes.get ctxt src >>=? fun copy_size ->\n return (ctxt, Z.add copy_size OPS.bytes_size_for_empty)\n | Alloc alloc ->\n OPS.Total_bytes.init ctxt id Z.zero >>=? fun ctxt ->\n OPS.alloc ctxt ~id alloc >>=? fun ctxt ->\n return (ctxt, OPS.bytes_size_for_empty)\n\n(**\n [apply_diff ctxt ops ~id diff] applies the diff [diff] on lazy storage [id]\n on storage context [ctxt] using operations [ops] and returns the updated\n storage context and the added size in bytes (may be negative).\n\n If [id] represents a temporary lazy storage, the added size may be wrong.\n*)\nlet apply_diff :\n type i a u.\n Raw_context.t ->\n (i, a, u) ops ->\n id:i ->\n (i, a, u) diff ->\n (Raw_context.t * Z.t) tzresult Lwt.t =\n fun ctxt ((module OPS) as ops) ~id diff ->\n match diff with\n | Remove ->\n if OPS.Id.is_temp id then\n OPS.remove ctxt id >|= fun ctxt -> ok (ctxt, Z.zero)\n else\n OPS.Total_bytes.get ctxt id >>=? fun size ->\n OPS.remove ctxt id >>= fun ctxt ->\n return (ctxt, Z.neg (Z.add size OPS.bytes_size_for_empty))\n | Update {init; updates} ->\n apply_init ctxt ops ~id init >>=? fun (ctxt, init_size) ->\n apply_updates ctxt ops ~id updates >>=? fun (ctxt, updates_size) ->\n return (ctxt, Z.add init_size updates_size)\n\ntype diffs_item =\n | Item :\n ('i, 'a, 'u) Lazy_storage_kind.t * 'i * ('i, 'a, 'u) diff\n -> diffs_item\n\nlet make :\n type i a u.\n (i, a, u) Lazy_storage_kind.t -> i -> (i, a, u) diff -> diffs_item =\n fun k id diff -> Item (k, id, diff)\n\nlet item_encoding =\n let open Data_encoding in\n union\n @@ List.map\n (fun (tag, Lazy_storage_kind.Ex_Kind k) ->\n let ops = get_ops k in\n let (module OPS) = ops in\n let title = OPS.title in\n case\n (Tag tag)\n ~title\n (obj3\n (req \"kind\" (constant title))\n (req \"id\" OPS.Id.encoding)\n (req \"diff\" (diff_encoding ops)))\n (fun (Item (kind, id, diff)) ->\n match Lazy_storage_kind.equal k kind with\n | Eq -> Some ((), id, diff)\n | Neq -> None)\n (fun ((), id, diff) -> Item (k, id, diff)))\n Lazy_storage_kind.all\n\nlet item_in_memory_size\n (Item\n ( kind (* kinds are constant tags *),\n _id_is_a_Z_fitting_in_an_int_for_a_long_time,\n diff )) =\n let open Cache_memory_helpers in\n ret_adding (diff_in_memory_size kind diff) h3w\n\ntype diffs = diffs_item list\n\nlet diffs_in_memory_size diffs =\n Cache_memory_helpers.list_fold_size item_in_memory_size diffs\n\nlet encoding =\n let open Data_encoding in\n def \"lazy_storage_diff\" @@ list item_encoding\n\nlet apply ctxt diffs =\n List.fold_left_es\n (fun (ctxt, total_size) (Item (k, id, diff)) ->\n let ops = get_ops k in\n apply_diff ctxt ops ~id diff >|=? fun (ctxt, added_size) ->\n let (module OPS) = ops in\n ( ctxt,\n if OPS.Id.is_temp id then total_size else Z.add total_size added_size ))\n (ctxt, Z.zero)\n diffs\n\nlet fresh :\n type i a u.\n (i, a, u) Lazy_storage_kind.t ->\n temporary:bool ->\n Raw_context.t ->\n (Raw_context.t * i) tzresult Lwt.t =\n fun kind ~temporary ctxt ->\n if temporary then\n return\n (Raw_context.fold_map_temporary_lazy_storage_ids ctxt (fun temp_ids ->\n Lazy_storage_kind.Temp_ids.fresh kind temp_ids))\n else\n let (module OPS) = get_ops kind in\n OPS.Next.incr ctxt\n\nlet init ctxt =\n List.fold_left_es\n (fun ctxt (_tag, Lazy_storage_kind.Ex_Kind k) ->\n let (module OPS) = get_ops k in\n OPS.Next.init ctxt)\n ctxt\n Lazy_storage_kind.all\n\nlet cleanup_temporaries ctxt =\n Raw_context.map_temporary_lazy_storage_ids_s ctxt (fun temp_ids ->\n List.fold_left_s\n (fun ctxt (_tag, Lazy_storage_kind.Ex_Kind k) ->\n let (module OPS) = get_ops k in\n Lazy_storage_kind.Temp_ids.fold_s k OPS.remove temp_ids ctxt)\n ctxt\n Lazy_storage_kind.all\n >|= fun ctxt -> (ctxt, Lazy_storage_kind.Temp_ids.init))\n" ;
} ;
{ name = "Commitment_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** [exists ctxt bpkh] returns true iff [bpkh] is associated to a non null\n commitment. *)\nval exists : Raw_context.t -> Blinded_public_key_hash.t -> bool Lwt.t\n\n(** [committed_amount ctxt bpkh] return the commitment associated to [bpkh], or\n [Tez_repr.zero] if [bpkh] has no associated commitment. *)\nval committed_amount :\n Raw_context.t -> Blinded_public_key_hash.t -> Tez_repr.t tzresult Lwt.t\n\nval increase_commitment_only_call_from_token :\n Raw_context.t ->\n Blinded_public_key_hash.t ->\n Tez_repr.t ->\n Raw_context.t tzresult Lwt.t\n\nval decrease_commitment_only_call_from_token :\n Raw_context.t ->\n Blinded_public_key_hash.t ->\n Tez_repr.t ->\n Raw_context.t tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nlet exists = Storage.Commitments.mem\n\nlet committed_amount ctxt bpkh =\n Storage.Commitments.find ctxt bpkh >>=? fun balance ->\n return (Option.value ~default:Tez_repr.zero balance)\n\nlet increase_commitment_only_call_from_token ctxt bpkh amount =\n if Tez_repr.(amount = zero) then return ctxt\n else\n committed_amount ctxt bpkh >>=? fun balance ->\n Tez_repr.(amount +? balance) >>?= fun new_balance ->\n Storage.Commitments.add ctxt bpkh new_balance >|= ok\n\nlet decrease_commitment_only_call_from_token ctxt bpkh amount =\n committed_amount ctxt bpkh >>=? fun balance ->\n Tez_repr.(balance -? amount) >>?= fun new_balance ->\n if Tez_repr.(new_balance = Tez_repr.zero) then\n Storage.Commitments.remove ctxt bpkh >|= ok\n else Storage.Commitments.add ctxt bpkh new_balance >|= ok\n" ;
} ;
{ name = "Voting_period_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Initializes the current context with voting period information. *)\nval init : Raw_context.t -> Voting_period_repr.t -> Raw_context.t tzresult Lwt.t\n\n(** Sets the initial period to [{voting_period = root; kind = Proposal;\n start_position}]. *)\nval init_first_period :\n Raw_context.t -> start_position:Int32.t -> Raw_context.t tzresult Lwt.t\n\n(** Increment the index by one and set the kind to Proposal. *)\nval reset : Raw_context.t -> Raw_context.t tzresult Lwt.t\n\n(** Increment the index by one and set the kind to its successor. *)\nval succ : Raw_context.t -> Raw_context.t tzresult Lwt.t\n\n(** Returns information about the current voting period. *)\nval get_current : Raw_context.t -> Voting_period_repr.t tzresult Lwt.t\n\n(** Returns the current voting period kind. *)\nval get_current_kind : Raw_context.t -> Voting_period_repr.kind tzresult Lwt.t\n\n(** Returns true if the context level is the last of current voting period. *)\nval is_last_block : Raw_context.t -> bool tzresult Lwt.t\n\n(** [blocks_before_activation ctxt] returns [Some b] if the current\n voting period is the Adoption and [b] blocks must be waited before activation\n of the next protocol amendment. Returns [None] if the current period is not\n Adoption (then more than [Constants_storage.blocks_per_voting_period] must\n be waited before activation). *)\nval blocks_before_activation : Raw_context.t -> int32 option tzresult Lwt.t\n\n(** Returns the voting period information for the current level. *)\nval get_rpc_current_info :\n Raw_context.t -> Voting_period_repr.info tzresult Lwt.t\n\n(** Returns the voting period information for the next level. *)\nval get_rpc_succ_info : Raw_context.t -> Voting_period_repr.info tzresult Lwt.t\n\nmodule Testnet_dictator : sig\n (** Overwrites the kind of the current voting period WITHOUT\n incrementing the index.\n\n Must ONLY be called by the testnet dictator on a testnet.\n\n @return [Error Storage_error] if the current voting period is\n not set or its deserialization fails. *)\n val overwrite_current_kind :\n Raw_context.t ->\n Chain_id.t ->\n Voting_period_repr.kind ->\n Raw_context.t tzresult Lwt.t\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* Copyright (c) 2022 Trili Tech <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(*\n The shell uses the convention that a context at level n is the resulting\n context of the application of block n.\n Therefore when using an RPC on the last level of a voting period, the context\n that is inspected is the resulting one.\n\n However [Amendment.may_start_new_voting_period] is run at the end of voting\n period and it has to prepare the context for validating operations of the next\n period. This causes the counter-intuitive result that the info returned by RPCs\n at last level of a voting period mention data of the next voting period.\n\n For example, when validating the last block of a proposal period at level n\n we have:\n - Input context:\n\n voting_period = { kind = Proposal;\n index = i;\n start_position = n - blocks_per_voting_period}\n\n - position = n - start_position = blocks_per_voting_period\n - remaining = blocks_per_voting_period - (position + 1) = 0\n\n - Output context:\n\n voting_period = { kind = Exploration;\n index = i + 1;\n start_position = n + 1}\n\n Now if we calculate position and remaining in the voting period we get\n strange results:\n - position = n - (n + 1) = -1\n - remaining = blocks_per_voting_period\n\n To work around this issue, two RPCs were added\n `Voting_period_storage.get_rpc_current_info`, which returns the correct\n info also for the last context of a period, and\n `Voting_period_storage.get_rpc_succ_info`, which can be used at the last\n context of a period to craft operations that will be valid for the first\n block of the new period.\n\n This odd behaviour could be fixed if [Amendment.may_start_new_voting_period]\n was called when we start validating the first block of a voting period instead\n that at the end of the validation of the last block of a voting period.\n This should be carefully done because the voting period listing depends on\n the rolls and it might break some invariant.\n\n When this is implemented one should:\n - edit the function [reset_current] and [inc_current] to use the\n current level and not the next one.\n - remove the storage for pred_kind\n - make Voting_period_repr.t abstract\n\n You can also look at the MR description here:\n https://gitlab.com/metastatedev/tezos/-/merge_requests/333\n *)\n\n(* Voting periods start at the first block of a cycle. More formally,\n the invariant of start_position with respect to cycle_position is:\n cycle_position mod blocks_per_cycle ==\n position_in_period mod blocks_per_cycle *)\n\nlet blocks_per_voting_period ctxt =\n let open Constants_storage in\n Int32.(mul (cycles_per_voting_period ctxt) (blocks_per_cycle ctxt))\n\nlet set_current = Storage.Vote.Current_period.update\n\nlet get_current = Storage.Vote.Current_period.get\n\nlet init = Storage.Vote.Current_period.init\n\nlet init_first_period ctxt ~start_position =\n init ctxt @@ Voting_period_repr.root ~start_position >>=? fun ctxt ->\n Storage.Vote.Pred_period_kind.init ctxt Voting_period_repr.Proposal\n\nlet common ctxt =\n get_current ctxt >>=? fun current_period ->\n Storage.Vote.Pred_period_kind.update ctxt current_period.kind >|=? fun ctxt ->\n let start_position =\n (* because we are preparing the voting period for the next block we need to\n use the next level. *)\n Int32.succ (Level_storage.current ctxt).level_position\n in\n (ctxt, current_period, start_position)\n\nlet reset ctxt =\n common ctxt >>=? fun (ctxt, current_period, start_position) ->\n Voting_period_repr.raw_reset current_period ~start_position\n |> set_current ctxt\n\nlet succ ctxt =\n common ctxt >>=? fun (ctxt, current_period, start_position) ->\n Voting_period_repr.raw_succ current_period ~start_position |> set_current ctxt\n\nlet get_current_kind ctxt = get_current ctxt >|=? fun {kind; _} -> kind\n\nlet get_current_info ctxt =\n get_current ctxt >|=? fun voting_period ->\n let blocks_per_voting_period = blocks_per_voting_period ctxt in\n let level = Level_storage.current ctxt in\n let position = Voting_period_repr.position_since level voting_period in\n let remaining =\n Voting_period_repr.remaining_blocks\n level\n voting_period\n ~blocks_per_voting_period\n in\n Voting_period_repr.{voting_period; position; remaining}\n\nlet get_current_remaining ctxt =\n get_current ctxt >|=? fun voting_period ->\n let blocks_per_voting_period = blocks_per_voting_period ctxt in\n Voting_period_repr.remaining_blocks\n (Level_storage.current ctxt)\n voting_period\n ~blocks_per_voting_period\n\nlet is_last_block ctxt =\n get_current_remaining ctxt >|=? fun remaining ->\n Compare.Int32.(remaining = 0l)\n\nlet blocks_before_activation ctxt =\n get_current ctxt >>=? function\n | Voting_period_repr.{kind = Adoption; _} ->\n get_current_remaining ctxt >>=? return_some\n | _ -> return_none\n\nlet get_rpc_current_info ctxt =\n get_current_info ctxt\n >>=? fun ({voting_period; position; _} as voting_period_info) ->\n if Compare.Int32.(position = Int32.minus_one) then\n let level = Level_storage.current ctxt in\n let blocks_per_voting_period = blocks_per_voting_period ctxt in\n Storage.Vote.Pred_period_kind.get ctxt >|=? fun pred_kind ->\n let voting_period : Voting_period_repr.t =\n {\n index = Int32.pred voting_period.index;\n kind = pred_kind;\n start_position =\n Int32.(sub voting_period.start_position blocks_per_voting_period);\n }\n in\n let position = Voting_period_repr.position_since level voting_period in\n let remaining =\n Voting_period_repr.remaining_blocks\n level\n voting_period\n ~blocks_per_voting_period\n in\n ({voting_period; remaining; position} : Voting_period_repr.info)\n else return voting_period_info\n\nlet get_rpc_succ_info ctxt =\n Level_storage.from_raw_with_offset\n ctxt\n ~offset:1l\n (Level_storage.current ctxt).level\n >>?= fun level ->\n get_current ctxt >|=? fun voting_period ->\n let blocks_per_voting_period = blocks_per_voting_period ctxt in\n let position = Voting_period_repr.position_since level voting_period in\n let remaining =\n Voting_period_repr.remaining_blocks\n level\n voting_period\n ~blocks_per_voting_period\n in\n Voting_period_repr.{voting_period; position; remaining}\n\nmodule Testnet_dictator = struct\n (* This error must never happen. It is deliberately unregistered so\n that the execution fails loudly if [overwrite_current_kind] is\n ever called on mainnet. *)\n type error += Forbidden_on_mainnet\n\n let overwrite_current_kind ctxt chain_id kind =\n error_when\n Chain_id.(chain_id = Constants_repr.mainnet_id)\n Forbidden_on_mainnet\n >>?= fun () ->\n get_current ctxt >>=? fun current_period ->\n let new_period = {current_period with kind} in\n set_current ctxt new_period\nend\n" ;
} ;
{ name = "Cache_repr" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(**\n\n Frequently used data should be kept in memory and persisted along a\n chain of blocks. The caching mechanism allows the economic protocol\n to declare such data and to rely on a Least Recently Used strategy\n to keep the cache size under a fixed limit.\n\n Take a look at {!Environment_cache} and {!Environment_context}\n for additional implementation details about the protocol cache.\n\n The protocol has two main kinds of interaction with the cache:\n\n 1. It is responsible for setting up the cache with appropriate\n parameter values and callbacks. It must also compute cache nonces\n to give the shell enough information to properly synchronize the\n in-memory cache with the block contexts and protocol upgrades.\n A typical place where this happens is {!Apply}.\n This aspect must be implemented using {!Cache.Admin}.\n\n 2. It can exploit the cache to retrieve, to insert, and to update\n cached values from the in-memory cache. The basic idea is to\n avoid recomputing values from scratch at each block when they are\n frequently used. {!Script_cache} is an example of such usage.\n This aspect must be implemented using {!Cache.Interface}.\n\n *)\n\n(** Size for subcaches and values of the cache. *)\ntype size = int\n\n(** Index type to index caches. *)\ntype index = int\n\n(** Type used to identifies the block that introduced new cache\n entries *)\ntype cache_nonce\n\n(**\n\n The following module acts on the whole cache, not on a specific\n sub-cache, unlike {!Interface}. It is used to administrate the\n protocol cache, e.g., to maintain the cache in a consistent state\n with respect to the chain. This module is typically used by\n low-level layers of the protocol and by the shell.\n\n*)\nmodule Admin : sig\n (** A key uniquely identifies a cached [value] in some subcache. *)\n type key\n\n (** Cached values. *)\n type value\n\n (** [pp fmt ctxt] is a pretty printer for the [cache] of [ctxt]. *)\n val pp : Format.formatter -> Raw_context.t -> unit\n\n (** [sync ctxt cache_nonce] updates the context with the domain of\n the cache computed so far. Such function is expected to be called\n at the end of the validation of a block, when there is no more\n accesses to the cache.\n\n [cache_nonce] identifies the block that introduced new cache\n entries. The nonce should identify uniquely the block which\n modifies this value. It cannot be the block hash for circularity\n reasons: The value of the nonce is stored onto the context and\n consequently influences the context hash of the very same\n block. Such nonce cannot be determined by the shell and its\n computation is delegated to the economic protocol. *)\n val sync : Raw_context.t -> cache_nonce -> Raw_context.t Lwt.t\n\n (** {3 Cache helpers for RPCs} *)\n\n (** [future_cache_expectation ?blocks_before_activation ctxt\n ~time_in_blocks] returns [ctxt] except that the entries of the\n caches that are presumably too old to still be in the caches in\n [n_blocks] are removed.\n\n This function is based on a heuristic. The context maintains the\n median of the number of removed entries: this number is multiplied\n by `n_blocks` to determine the entries that are likely to be\n removed in `n_blocks`.\n\n If [blocks_before_activation] is set to [Some n],\n then the cache is considered empty if [0 <= n <= time_in_blocks].\n Otherwise, if [blocks_before_activation] is set to [None] and\n if the voting period is the adoption, the cache is considered\n empty if [blocks <= time_in_blocks remaining for adoption phase]. *)\n val future_cache_expectation :\n ?blocks_before_activation:int32 ->\n Raw_context.t ->\n time_in_blocks:int ->\n Raw_context.t tzresult Lwt.t\n\n (** [cache_size ctxt ~cache_index] returns an overapproximation of\n the size of the cache. Returns [None] if [cache_index] is\n greater than the number of subcaches declared by the cache\n layout. *)\n val cache_size : Raw_context.t -> cache_index:int -> size option\n\n (** [cache_size_limit ctxt ~cache_index] returns the maximal size of\n the cache indexed by [cache_index]. Returns [None] if\n [cache_index] is greater than the number of subcaches declared\n by the cache layout. *)\n val cache_size_limit : Raw_context.t -> cache_index:int -> size option\n\n (** [value_of_key ctxt k] interprets the functions introduced by\n [register] to construct a cacheable value for a key [k].\n\n [value_of_key] is a maintenance operation: it is typically run\n when a node reboots. For this reason, this operation is not\n carbonated. *)\n val value_of_key :\n Raw_context.t -> Context.Cache.key -> Context.Cache.value tzresult Lwt.t\nend\n\n(** A client uses a unique namespace (represented as a string\n without '@') to avoid collision with the keys of other\n clients. *)\ntype namespace = private string\n\n(** [create_namespace str] creates a valid namespace from [str]\n\n @raise Invalid_argument if [str] contains '@'\n *)\nval create_namespace : string -> namespace\n\n(** A key is fully determined by a namespace and an identifier. *)\ntype identifier = string\n\n(**\n To use the cache, a client must implement the [CLIENT]\n interface.\n\n *)\nmodule type CLIENT = sig\n (** The type of value to be stored in the cache. *)\n type cached_value\n\n (** The client must declare the index of the subcache where its\n values shall live. [cache_index] must be between [0] and\n [List.length Constants_repr.cache_layout - 1]. *)\n val cache_index : index\n\n (** The client must declare a namespace. This namespace must\n be unique. Otherwise, the program stops.\n A namespace cannot contain '@'. *)\n val namespace : namespace\n\n (** [value_of_identifier id] builds the cached value identified by\n [id]. This function is called when the subcache is loaded into\n memory from the on-disk representation of its domain.\n\n An error during the execution of this function is fatal as\n witnessed by its type: an error embedded in a [tzresult] is not\n supposed to be caught by the protocol. *)\n val value_of_identifier :\n Raw_context.t -> identifier -> cached_value tzresult Lwt.t\nend\n\n(**\n\n An [INTERFACE] to the subcache where keys live in a given [namespace].\n\n *)\nmodule type INTERFACE = sig\n (** The type of value to be stored in the cache. *)\n type cached_value\n\n (** [update ctxt i (Some (e, size))] returns a context where the\n value [e] of given [size] is associated to identifier [i] in\n the subcache. If [i] is already in the subcache, the cache\n entry is updated.\n\n [update ctxt i None] removes [i] from the subcache. *)\n val update :\n Raw_context.t ->\n identifier ->\n (cached_value * size) option ->\n Raw_context.t tzresult\n\n (** [find ctxt i = Some v] if [v] is the value associated to [i]\n in the subcache. Returns [None] if there is no such value in\n the subcache. This function is in the Lwt monad because if the\n value may have not been constructed (see the lazy loading\n mode in {!Environment_context}), it is constructed on the fly. *)\n val find : Raw_context.t -> identifier -> cached_value option tzresult Lwt.t\n\n (** [list_identifiers ctxt] returns the list of the\n identifiers of the cached values along with their respective\n size. The returned list is sorted in terms of their age in the\n cache, the oldest coming first. *)\n val list_identifiers : Raw_context.t -> (string * int) list\n\n (** [identifier_rank ctxt identifier] returns the number of cached values\n older than the one of [identifier]; or, [None] if the [identifier] has\n no associated value in the subcache. *)\n val identifier_rank : Raw_context.t -> string -> int option\n\n (** [size ctxt] returns an overapproximation of the subcache size.\n Note that the size unit is subcache specific. *)\n val size : Raw_context.t -> int\n\n (** [size_limit ctxt] returns the maximal size of the subcache.\n Note that the size unit is subcache specific. *)\n val size_limit : Raw_context.t -> int\nend\n\n(** [register_exn client] produces an [Interface] specific to a\n given [client]. This function can fail if [client] does not\n respect the invariant declared in the documentation of\n {!CLIENT}. *)\nval register_exn :\n (module CLIENT with type cached_value = 'a) ->\n (module INTERFACE with type cached_value = 'a)\n\n(** [cache_nonce_from_block_header shell_header contents] computes a\n {!cache_nonce} from the [shell_header] and its [contents]. *)\nval cache_nonce_from_block_header :\n Block_header_repr.shell_header -> Block_header_repr.contents -> cache_nonce\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule Cache_costs = struct\n module S = Saturation_repr\n\n (* Computed by typing the contract\n \"{parameter unit; storage unit; code FAILWITH}\"\n and evaluating\n [(8 * Obj.reachable_words (Obj.repr typed_script))]\n where [typed_script] is of type [ex_script] *)\n let minimal_size_of_typed_contract_in_bytes = 688\n\n let approximate_cardinal bytes =\n S.safe_int (bytes / minimal_size_of_typed_contract_in_bytes)\n\n let log2 x = S.safe_int (1 + S.numbits x)\n\n let cache_update_constant = S.safe_int 600\n\n let cache_update_coeff = S.safe_int 43\n\n (* Cost of calling [Environment_cache.update]. *)\n let cache_update ~cache_size_in_bytes =\n let approx_card = approximate_cardinal cache_size_in_bytes in\n Gas_limit_repr.atomic_step_cost\n S.(add cache_update_constant (mul cache_update_coeff (log2 approx_card)))\n\n (* Cost of calling [Environment_cache.find].\n This overapproximates [cache_find] slightly. *)\n let cache_find = cache_update\nend\n\ntype index = int\n\ntype size = int\n\ntype identifier = string\n\ntype namespace = string\n\ntype cache_nonce = Bytes.t\n\nlet compare_namespace = Compare.String.compare\n\ntype internal_identifier = {namespace : namespace; id : identifier}\n\nlet separator = '@'\n\nlet sanitize namespace =\n if String.contains namespace separator then\n invalid_arg\n (Format.asprintf\n \"Invalid cache namespace: '%s'. Character %c is forbidden.\"\n namespace\n separator)\n else namespace\n\nlet create_namespace = sanitize\n\nlet string_of_internal_identifier {namespace; id} =\n namespace ^ String.make 1 separator ^ id\n\nlet internal_identifier_of_string raw =\n match String.index_opt raw separator with\n | None -> assert false\n | Some index ->\n {\n (* We do not need to call sanitize here since we stop at the first '@'\n from index 0. It is a guarantee that there is no '@' between 0 and\n (index - 1 ). *)\n namespace = String.sub raw 0 index;\n id =\n (let delim_idx = index + 1 in\n String.sub raw delim_idx (String.length raw - delim_idx));\n }\n\nlet internal_identifier_of_key key =\n let raw = Raw_context.Cache.identifier_of_key key in\n internal_identifier_of_string raw\n\nlet key_of_internal_identifier ~cache_index identifier =\n let raw = string_of_internal_identifier identifier in\n Raw_context.Cache.key_of_identifier ~cache_index raw\n\nlet make_key =\n let namespaces = ref [] in\n fun ~cache_index ~namespace ->\n if List.mem ~equal:String.equal namespace !namespaces then\n invalid_arg\n (Format.sprintf \"Cache key namespace %s already exist.\" namespace)\n else (\n namespaces := namespace :: !namespaces ;\n fun ~id ->\n let identifier = {namespace; id} in\n key_of_internal_identifier ~cache_index identifier)\n\nmodule NamespaceMap = Map.Make (struct\n type t = namespace\n\n let compare = compare_namespace\nend)\n\ntype partial_key_handler =\n Raw_context.t -> string -> Context.Cache.value tzresult Lwt.t\n\nlet value_of_key_handlers : partial_key_handler NamespaceMap.t ref =\n ref NamespaceMap.empty\n\nmodule Admin = struct\n include Raw_context.Cache\n\n let future_cache_expectation ?blocks_before_activation ctxt ~time_in_blocks =\n let time_in_blocks' = Int32.of_int time_in_blocks in\n let blocks_per_voting_period =\n Int32.(\n mul\n (Constants_storage.cycles_per_voting_period ctxt)\n (Constants_storage.blocks_per_cycle ctxt))\n in\n (match blocks_before_activation with\n | None -> Voting_period_storage.blocks_before_activation ctxt\n | Some block -> return_some block)\n >>=? function\n | Some block\n when Compare.Int32.(\n (Compare.Int32.(block >= 0l) && block <= time_in_blocks')\n || blocks_per_voting_period < time_in_blocks') ->\n (*\n\n At each protocol activation, the cache is clear.\n\n For this reason, if the future block considered for the\n prediction is after the activation, the predicted cache\n is set to empty. That way, the predicted gas consumption\n is guaranteed to be an overapproximation of the actual\n gas consumption.\n\n This function implicitly assumes that [time_in_blocks]\n is less than [blocks_per_voting_period]. (The default\n value in the simulate_operation RPC is set to 3, and\n therefore satisfies this condition.) As a defensive\n protection, we clear the cache if this assumption is\n not satisfied with user-provided values. Notice that\n high user-provided values for [time_in_blocks] do not\n make much sense as the cache prediction only works for\n blocks in the short-term future.\n\n *)\n return @@ Raw_context.Cache.clear ctxt\n | _ ->\n return\n @@ Raw_context.Cache.future_cache_expectation ctxt ~time_in_blocks\n\n let list_keys context ~cache_index =\n Raw_context.Cache.list_keys context ~cache_index\n\n let key_rank context key = Raw_context.Cache.key_rank context key\n\n let value_of_key ctxt key =\n (* [value_of_key] is a maintenance operation: it is typically run\n when a node reboots. For this reason, this operation is not\n carbonated. *)\n let ctxt = Raw_context.set_gas_unlimited ctxt in\n let {namespace; id} = internal_identifier_of_key key in\n match NamespaceMap.find namespace !value_of_key_handlers with\n | Some value_of_key -> value_of_key ctxt id\n | None ->\n failwith\n (Format.sprintf \"No handler for key `%s%c%s'\" namespace separator id)\nend\n\nmodule type CLIENT = sig\n val cache_index : int\n\n val namespace : namespace\n\n type cached_value\n\n val value_of_identifier :\n Raw_context.t -> identifier -> cached_value tzresult Lwt.t\nend\n\nmodule type INTERFACE = sig\n type cached_value\n\n val update :\n Raw_context.t ->\n identifier ->\n (cached_value * int) option ->\n Raw_context.t tzresult\n\n val find : Raw_context.t -> identifier -> cached_value option tzresult Lwt.t\n\n val list_identifiers : Raw_context.t -> (identifier * int) list\n\n val identifier_rank : Raw_context.t -> identifier -> int option\n\n val size : Raw_context.t -> size\n\n val size_limit : Raw_context.t -> size\nend\n\nlet register_exn (type cvalue)\n (module C : CLIENT with type cached_value = cvalue) :\n (module INTERFACE with type cached_value = cvalue) =\n if\n Compare.Int.(C.cache_index < 0)\n || Compare.Int.(Constants_repr.cache_layout_size <= C.cache_index)\n then invalid_arg \"Cache index is invalid\" ;\n let mk = make_key ~cache_index:C.cache_index ~namespace:C.namespace in\n (module struct\n type cached_value = C.cached_value\n\n type Admin.value += K of cached_value\n\n let () =\n let voi ctxt i =\n C.value_of_identifier ctxt i >>=? fun v -> return (K v)\n in\n value_of_key_handlers :=\n NamespaceMap.add C.namespace voi !value_of_key_handlers\n\n let size ctxt =\n Option.value ~default:max_int\n @@ Admin.cache_size ctxt ~cache_index:C.cache_index\n\n let size_limit ctxt =\n Option.value ~default:0\n @@ Admin.cache_size_limit ctxt ~cache_index:C.cache_index\n\n let update ctxt id v =\n let cache_size_in_bytes = size ctxt in\n Raw_context.consume_gas\n ctxt\n (Cache_costs.cache_update ~cache_size_in_bytes)\n >|? fun ctxt ->\n let v = Option.map (fun (v, size) -> (K v, size)) v in\n Admin.update ctxt (mk ~id) v\n\n let find ctxt id =\n let cache_size_in_bytes = size ctxt in\n Raw_context.consume_gas ctxt (Cache_costs.cache_find ~cache_size_in_bytes)\n >>?= fun ctxt ->\n Admin.find ctxt (mk ~id) >>= function\n | None -> return None\n | Some (K v) -> return (Some v)\n | _ ->\n (* This execution path is impossible because all the keys of\n C's namespace (which is unique to C) are constructed with\n [K]. This [assert false] could have been pushed into the\n environment in exchange for extra complexity. The\n argument that justifies this [assert false] seems\n simple enough to keep the current design though. *)\n assert false\n\n let list_identifiers ctxt =\n Admin.list_keys ctxt ~cache_index:C.cache_index |> function\n | None ->\n (* `cache_index` is valid. *)\n assert false\n | Some list ->\n List.filter_map\n (fun (key, age) ->\n let {namespace; id} = internal_identifier_of_key key in\n if String.equal namespace C.namespace then Some (id, age)\n else None)\n list\n\n let identifier_rank ctxt id = Admin.key_rank ctxt (mk ~id)\n end)\n\nlet cache_nonce_from_block_header (shell : Block_header.shell_header) contents :\n cache_nonce =\n let open Block_header_repr in\n let shell : Block_header.shell_header =\n {\n level = 0l;\n proto_level = 0;\n predecessor = shell.predecessor;\n timestamp = Time.of_seconds 0L;\n validation_passes = 0;\n operations_hash = shell.operations_hash;\n fitness = [];\n context = Context_hash.zero;\n }\n in\n let contents =\n {\n contents with\n payload_hash = Block_payload_hash.zero;\n proof_of_work_nonce =\n Bytes.make Constants_repr.proof_of_work_nonce_size '0';\n }\n in\n let protocol_data = {signature = Signature.zero; contents} in\n let x = {shell; protocol_data} in\n Block_hash.to_bytes (hash x)\n" ;
} ;
{ name = "Zk_rollup_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** These errors are only to be matched in tests. *)\ntype error +=\n | Zk_rollup_does_not_exist of Zk_rollup_repr.t\n (** Emitted when trying to perform an operation over a ZK rollup\n that hasn't been initialised. *)\n | Zk_rollup_invalid_op_code of int\n (** Emitted when trying to add to the pending list and operation\n with an invalid op code. *)\n | Zk_rollup_pending_list_too_short\n (** Emitted when trying to process more public operations than\n those available in the pending list. *)\n\n(** [account context rollup] fetches the ZK [rollup]'s account from the\n storage.\n*)\nval account :\n Raw_context.t ->\n Zk_rollup_repr.t ->\n (Raw_context.t * Zk_rollup_account_repr.t) tzresult Lwt.t\n\n(* [pending_list context rollup] fetches the ZK [rollup]'s\n pending list description from the storage.\n See {! Zk_rollup_repr.pending_list}. *)\nval pending_list :\n Raw_context.t ->\n Zk_rollup_repr.t ->\n (Raw_context.t * Zk_rollup_repr.pending_list) tzresult Lwt.t\n\n(* [pending_op context rollup i] fetches the [i]th L2 operation from\n ZK [rollup]'s pending list, alongside an optional ticket hash\n to perform an exit (see {!Zk_rollup_apply} for more details).\n*)\nval pending_op :\n Raw_context.t ->\n Zk_rollup_repr.t ->\n int64 ->\n (Raw_context.t * (Zk_rollup_operation_repr.t * Ticket_hash_repr.t option))\n tzresult\n Lwt.t\n\n(** [originate context static ~init_state] produces an address [a] for\n a ZK rollup storage using the [origination_nonce] from\n the [context]. This function also initializes the storage,\n indexing the initial ZKRU account by [a].\n\n Returns the new context and ZKRU address, alongside the size\n of the new account.\n*)\nval originate :\n Raw_context.t ->\n Zk_rollup_account_repr.static ->\n init_state:Zk_rollup_state_repr.t ->\n (Raw_context.t * Zk_rollup_repr.t * Z.t) tzresult Lwt.t\n\n(** [add_to_pending context rollup operations] appends to the\n ZK [rollup]'s pending list a list of L2 [operations].\n Returns the new context alongside the size of the new operations.\n\n May fail with:\n {ul\n {li [Zk_rollup_invalid_op_code op_code] if the [op_code]\n of one of the [operations] is greater or equal to the\n number of declared operations for this [rollup].\n }\n }\n*)\nval add_to_pending :\n Raw_context.t ->\n Zk_rollup_repr.t ->\n (Zk_rollup_operation_repr.t * Ticket_hash_repr.t option) list ->\n (Raw_context.t * Z.t) tzresult Lwt.t\n\n(** [get_pending_length context rollup] returns the length of a\n ZK [rollup]'s pending list.\n*)\nval get_pending_length :\n Raw_context.t -> Zk_rollup_repr.t -> (Raw_context.t * int) tzresult Lwt.t\n\n(** [get_prefix context rollup n] returns the prefix of length [n]\n of the [rollup]'s pending list.\n\n May fail with:\n {ul\n {li [Zk_rollup_pending_list_too_short] if [n] is greater than\n the length of the pending list.}\n {li [Zk_rollup_negative_length] if [n] is negative.}\n }\n*)\nval get_prefix :\n Raw_context.t ->\n Zk_rollup_repr.t ->\n int ->\n (Raw_context.t\n * (Zk_rollup_operation_repr.t * Ticket_hash_repr.t option) list)\n tzresult\n Lwt.t\n\n(** [update context rollup ~pending_to_drop ~new_account] sets the\n [rollup]'s account to [new_account]. Additionally, it removes\n the first [pending_to_drop] entries from the [rollup]'s pending\n list.\n Returns the new context.\n\n May fail with:\n {ul\n {li [Zk_rollup_pending_list_too_short] if [pending_to_drop] is\n greater than the length of the pending list.}\n {li [Zk_rollup_negative_length] if [pending_to_drop] is negative.}\n }\n*)\nval update :\n Raw_context.t ->\n Zk_rollup_repr.t ->\n pending_to_drop:int ->\n new_account:Zk_rollup_account_repr.t ->\n Raw_context.t tzresult Lwt.t\n\n(** [assert_exist context rollup] asserts that [rollup] has been initialized.\n Returns the new context.\n\n May fail with:\n {ul\n {li [Zk_rollup_does_not_exist] if [rollup] is not found.}\n }\n*)\nval assert_exist :\n Raw_context.t -> Zk_rollup_repr.t -> Raw_context.t tzresult Lwt.t\n\n(** [exists context rollup] returns a boolean representing whether\n [rollup] has been initialized.\n*)\nval exists :\n Raw_context.t -> Zk_rollup_repr.t -> (Raw_context.t * bool) tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error +=\n | Zk_rollup_does_not_exist of Zk_rollup_repr.t\n | Zk_rollup_invalid_op_code of int\n | Zk_rollup_pending_list_too_short\n | Zk_rollup_negative_length\n\nlet () =\n register_error_kind\n `Temporary\n ~id:\"Zk_rollup_does_not_exist\"\n ~title:\"ZK Rollup does not exist\"\n ~description:\"Attempted to use a ZK rollup that has not been originated.\"\n ~pp:(fun ppf x ->\n Format.fprintf ppf \"Rollup %a does not exist\" Zk_rollup_repr.Address.pp x)\n Data_encoding.(obj1 (req \"rollup\" Zk_rollup_repr.Address.encoding))\n (function Zk_rollup_does_not_exist x -> Some x | _ -> None)\n (fun x -> Zk_rollup_does_not_exist x) ;\n register_error_kind\n `Permanent\n ~id:\"Zk_rollup_invalid_op code\"\n ~title:\"Invalid op code in append\"\n ~description:\"Invalid op code in append\"\n ~pp:(fun ppf oc ->\n Format.fprintf ppf \"Op code %d is not valid for this ZK Rollup\" oc)\n Data_encoding.(obj1 (req \"op_code\" int31))\n (function Zk_rollup_invalid_op_code oc -> Some oc | _ -> None)\n (fun oc -> Zk_rollup_invalid_op_code oc) ;\n register_error_kind\n `Temporary\n ~id:\"Zk_rollup_pending_list_too_short\"\n ~title:\"Pending list is too short\"\n ~description:\"Pending list is too short\"\n Data_encoding.unit\n (function Zk_rollup_pending_list_too_short -> Some () | _ -> None)\n (fun () -> Zk_rollup_pending_list_too_short) ;\n register_error_kind\n `Permanent\n ~id:\"Zk_rollup_negative_length\"\n ~title:\"Negative length for pending list prefix\"\n ~description:\"Negative length for pending list prefix\"\n Data_encoding.unit\n (function Zk_rollup_negative_length -> Some () | _ -> None)\n (fun () -> Zk_rollup_negative_length)\n\nlet account = Storage.Zk_rollup.Account.get\n\nlet pending_list = Storage.Zk_rollup.Pending_list.get\n\nlet pending_op ctxt id = Storage.Zk_rollup.Pending_operation.get (ctxt, id)\n\nlet originate ctxt static ~init_state =\n let open Lwt_result_syntax in\n let*? ctxt, nonce = Raw_context.increment_origination_nonce ctxt in\n let*? address = Zk_rollup_repr.Address.from_nonce nonce in\n let origination_size = Constants_storage.zk_rollup_origination_size ctxt in\n let initial_account =\n Zk_rollup_account_repr.\n {\n static;\n dynamic =\n {\n state = init_state;\n paid_l2_operations_storage_space = Z.of_int origination_size;\n used_l2_operations_storage_space = Z.zero;\n };\n }\n in\n let* ctxt, account_size =\n Storage.Zk_rollup.Account.init ctxt address initial_account\n in\n let init_pl = Zk_rollup_repr.(Empty {next_index = 0L}) in\n let* ctxt, pl_size =\n Storage.Zk_rollup.Pending_list.init ctxt address init_pl\n in\n let address_size = Zk_rollup_repr.Address.size in\n let size =\n Z.of_int (origination_size + address_size + account_size + pl_size)\n in\n return (ctxt, address, size)\n\nlet add_to_pending ctxt rollup ops =\n let open Lwt_result_syntax in\n let open Zk_rollup_repr in\n let open Zk_rollup_operation_repr in\n let* ctxt, acc = account ctxt rollup in\n let*? () =\n List.iter_e\n (fun (op, _ticket_hash_opt) ->\n if Compare.Int.(op.op_code >= acc.static.nb_ops || op.op_code < 0) then\n error @@ Zk_rollup_invalid_op_code op.op_code\n else ok ())\n ops\n in\n let* ctxt, pl = Storage.Zk_rollup.Pending_list.get ctxt rollup in\n let next_index, length =\n match pl with\n | Empty {next_index} -> (next_index, 0)\n | Pending {next_index; length} -> (next_index, length)\n in\n let* ctxt, next_index, length, storage_diff =\n List.fold_left_es\n (fun (ctxt, next_index, length, storage_diff) op ->\n let* ctxt, new_storage_diff, _was_bound =\n Storage.Zk_rollup.Pending_operation.add (ctxt, rollup) next_index op\n in\n return\n ( ctxt,\n Int64.succ next_index,\n length + 1,\n new_storage_diff + storage_diff ))\n (ctxt, next_index, length, 0)\n ops\n in\n let used_l2_operations_storage_space =\n Z.(add acc.dynamic.used_l2_operations_storage_space (Z.of_int storage_diff))\n in\n let l2_operations_storage_space_to_pay =\n Z.(\n max\n zero\n (sub\n used_l2_operations_storage_space\n acc.dynamic.paid_l2_operations_storage_space))\n in\n let paid_l2_operations_storage_space =\n Z.(\n add\n acc.dynamic.paid_l2_operations_storage_space\n l2_operations_storage_space_to_pay)\n in\n let acc =\n {\n acc with\n dynamic =\n {\n acc.dynamic with\n paid_l2_operations_storage_space;\n used_l2_operations_storage_space;\n };\n }\n in\n\n let pl =\n if Compare.Int.(length = 0) then Empty {next_index}\n else Pending {next_index; length}\n in\n (* Users aren't charged for storage diff in the account or pending list\n description of a ZKRU.\n When updating a ZKRU account, the storage diff can only come from the\n dynamically sized [Z.t] used for the watermark. These changes\n in storage size will not be accounted for.\n As for the pending list description, the storage size is fixed for\n each of the two cases (empty / non-empty). Then, there will be a storage\n diff when switching between these two, which won't be accounted for\n either.\n *)\n let* ctxt, _diff_acc = Storage.Zk_rollup.Account.update ctxt rollup acc in\n let* ctxt, _diff_pl = Storage.Zk_rollup.Pending_list.update ctxt rollup pl in\n return (ctxt, l2_operations_storage_space_to_pay)\n\nlet pending_length =\n let open Zk_rollup_repr in\n function Empty _ -> 0 | Pending {length; _} -> length\n\nlet head =\n let open Zk_rollup_repr in\n function\n | Empty _ -> error Zk_rollup_pending_list_too_short\n | Pending {next_index; length} ->\n Result_syntax.return Int64.(sub next_index (of_int length))\n\nlet next_index =\n let open Zk_rollup_repr in\n function\n | Empty {next_index} -> next_index | Pending {next_index; _} -> next_index\n\nlet get_pending_length ctxt rollup =\n let open Lwt_result_syntax in\n let* ctxt, pl = pending_list ctxt rollup in\n return (ctxt, pending_length pl)\n\n(** Same as [Tezos_stdlib.Utils.fold_n_times] but with Lwt and Error monad *)\nlet fold_n_times_es ~when_negative n f e =\n let open Lwt_result_syntax in\n if Compare.Int.(n < 0) then tzfail when_negative\n else\n let rec go acc = function\n | 0 -> return acc\n | n ->\n let* acc = f acc in\n (go [@ocaml.tailcall]) acc (n - 1)\n in\n go e n\n\nlet get_prefix ctxt rollup n =\n let open Lwt_result_syntax in\n if Compare.Int.(n = 0) then return (ctxt, [])\n else\n let* ctxt, pl = pending_list ctxt rollup in\n let pl_length = pending_length pl in\n let*? () =\n error_when Compare.Int.(n > pl_length) Zk_rollup_pending_list_too_short\n in\n let*? hd = head pl in\n let* ctxt, ops, _i =\n (* Get the l2 ops corresponding to indeces [hd + n - 1 .. hd],\n so that the accumulated list is in the right order *)\n fold_n_times_es\n ~when_negative:Zk_rollup_negative_length\n n\n (fun (ctxt, ops, i) ->\n let* ctxt, op = pending_op ctxt rollup i in\n return (ctxt, op :: ops, Int64.pred i))\n (ctxt, [], Int64.(sub (add hd (of_int n)) 1L))\n in\n return (ctxt, ops)\n\nlet update ctxt rollup ~pending_to_drop ~new_account =\n let open Lwt_result_syntax in\n let open Zk_rollup_repr in\n let open Zk_rollup_account_repr in\n let* ctxt, pl = pending_list ctxt rollup in\n let* ctxt, acc = account ctxt rollup in\n let pl_length = pending_length pl in\n let*? () =\n error_when\n Compare.Int.(pending_to_drop > pl_length)\n Zk_rollup_pending_list_too_short\n in\n let next_index = next_index pl in\n (* Drop the indeces from [head] to [head + pending_to_drop - 1]\n from the storage of L2 operations. *)\n let* ctxt, freed =\n match head pl with\n | Error _e ->\n (* If the pending list is empty, then [pending_to_drop] must be 0. *)\n return (ctxt, 0)\n | Ok head ->\n let* ctxt, freed, _i =\n fold_n_times_es\n ~when_negative:Zk_rollup_negative_length\n pending_to_drop\n (fun (ctxt, freed, i) ->\n let* ctxt, new_freed, _bound =\n Storage.Zk_rollup.Pending_operation.remove (ctxt, rollup) i\n in\n return (ctxt, freed + new_freed, Int64.succ i))\n (ctxt, 0, head)\n in\n return (ctxt, freed)\n in\n (* Subtract the bytes freed by removing pending operations from\n acc.dynamic.used_l2_operations_storage_space, and update\n [new_account].\n *)\n let used_l2_operations_storage_space =\n Z.(sub acc.dynamic.used_l2_operations_storage_space (Z.of_int freed))\n in\n let new_account =\n {\n new_account with\n dynamic =\n {\n state = new_account.dynamic.state;\n paid_l2_operations_storage_space =\n new_account.dynamic.paid_l2_operations_storage_space;\n used_l2_operations_storage_space;\n };\n }\n in\n let* ctxt, _diff_acc =\n Storage.Zk_rollup.Account.update ctxt rollup new_account\n in\n (* Update the pending list descriptor *)\n let pl_length = pl_length - pending_to_drop in\n let pl =\n if Compare.Int.(pl_length = 0) then Empty {next_index}\n else Pending {next_index; length = pl_length}\n in\n let* ctxt, _diff_pl = Storage.Zk_rollup.Pending_list.update ctxt rollup pl in\n return ctxt\n\nlet assert_exist ctxt rollup =\n let open Lwt_result_syntax in\n let* ctxt, exists = Storage.Zk_rollup.Account.mem ctxt rollup in\n let*? () = error_unless exists (Zk_rollup_does_not_exist rollup) in\n return ctxt\n\nlet exists ctxt rollup = Storage.Zk_rollup.Account.mem ctxt rollup\n" ;
} ;
{ name = "Contract_delegate_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module deals with the delegates of a contract. It is\n responsible for maintaining the tables {!Storage.Contract.Delegate}\n and {!Storage.Contract.Delegated}. *)\n\ntype error +=\n | (* `Permanent *)\n Forbidden_tz4_delegate of Bls.Public_key_hash.t\n (** Delegates cannot be tz4 accounts (i.e. BLS public key hashes). This\n error is returned when we try to register such a delegate. *)\n\n(** [check_not_tz4 pkh] checks that [pkh] is not a BLS address. *)\nval check_not_tz4 : Signature.public_key_hash -> unit tzresult\n\n(** [find ctxt contract] returns the delegate associated to [contract], or [None]\n if [contract] has no delegate. *)\nval find :\n Raw_context.t ->\n Contract_repr.t ->\n Signature.Public_key_hash.t option tzresult Lwt.t\n\n(** [init ctxt contract delegate] sets the [delegate] associated to [contract].\n\n This function assumes that [contract] does not have a delegate already. *)\nval init :\n Raw_context.t ->\n Contract_repr.t ->\n Signature.Public_key_hash.t ->\n Raw_context.t tzresult Lwt.t\n\n(** [unlink ctxt contract] removes [contract] from the list of contracts that\n delegated to [find ctxt contract], i.e. the output of [delegated_contracts].\n This function does not affect the value of the expression\n [find ctxt contract].\n\n This function assumes that [contract] is allocated. *)\nval unlink : Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t\n\n(** [delete ctxt contract] behaves as [unlink ctxt contract], but in addition\n removes the association of the [contract] to its current delegate, leaving\n the former without delegate.\n\n This function assumes that [contract] is allocated. *)\nval delete : Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t\n\n(** [set ctxt contract delegate] updates the [delegate] associated to [contract].\n\n This function assumes that [contract] is allocated and has a delegate. *)\nval set :\n Raw_context.t ->\n Contract_repr.t ->\n Signature.Public_key_hash.t ->\n Raw_context.t tzresult Lwt.t\n\n(** [delegated_contracts ctxt delegate] returns the list of contracts (implicit\n or originated) that delegated to [delegate]. *)\nval delegated_contracts :\n Raw_context.t -> Signature.Public_key_hash.t -> Contract_repr.t list Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error += (* `Permanent *) Forbidden_tz4_delegate of Bls.Public_key_hash.t\n\nlet () =\n register_error_kind\n `Branch\n ~id:\"delegate.forbidden_tz4\"\n ~title:\"Forbidden delegate\"\n ~description:\"Delegates are forbidden to be tz4 (BLS) accounts.\"\n ~pp:(fun ppf implicit ->\n Format.fprintf\n ppf\n \"The delegate %a is forbidden as it is a BLS public key hash.\"\n Bls.Public_key_hash.pp\n implicit)\n Data_encoding.(obj1 (req \"delegate\" Bls.Public_key_hash.encoding))\n (function Forbidden_tz4_delegate d -> Some d | _ -> None)\n (fun d -> Forbidden_tz4_delegate d)\n\nlet check_not_tz4 : Signature.Public_key_hash.t -> unit tzresult = function\n | Bls tz4 -> error (Forbidden_tz4_delegate tz4)\n | Ed25519 _ | Secp256k1 _ | P256 _ -> Ok ()\n\nlet find = Storage.Contract.Delegate.find\n\nlet init ctxt contract delegate =\n check_not_tz4 delegate >>?= fun () ->\n Storage.Contract.Delegate.init ctxt contract delegate >>=? fun ctxt ->\n let delegate_contract = Contract_repr.Implicit delegate in\n Storage.Contract.Delegated.add (ctxt, delegate_contract) contract >|= ok\n\nlet unlink ctxt contract =\n Storage.Contract.Delegate.find ctxt contract >>=? function\n | None -> return ctxt\n | Some delegate ->\n let delegate_contract = Contract_repr.Implicit delegate in\n Storage.Contract.Delegated.remove (ctxt, delegate_contract) contract\n >|= ok\n\nlet delete ctxt contract =\n unlink ctxt contract >>=? fun ctxt ->\n Storage.Contract.Delegate.remove ctxt contract >|= ok\n\nlet set ctxt contract delegate =\n check_not_tz4 delegate >>?= fun () ->\n unlink ctxt contract >>=? fun ctxt ->\n Storage.Contract.Delegate.add ctxt contract delegate >>= fun ctxt ->\n let delegate_contract = Contract_repr.Implicit delegate in\n Storage.Contract.Delegated.add (ctxt, delegate_contract) contract >|= ok\n\nlet delegated_contracts ctxt delegate =\n let contract = Contract_repr.Implicit delegate in\n Storage.Contract.Delegated.elements (ctxt, contract)\n" ;
} ;
{ name = "Stake_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module provides basic operations (accessors and setters) on\n staking tokens.\n\n It is responsible for maintaining the following tables:\n - {!Storage.Stake.Selected_distribution_for_cycle}\n - {!Storage.Stake.Staking_balance}\n - {!Storage.Stake.Active_delegate_with_one_roll}\n - {!Storage.Stake.Last_snapshot}\n - {!Storage.Stake.Total_active_stake}\n*)\n\nval remove_stake :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Tez_repr.t ->\n Raw_context.t tzresult Lwt.t\n\nval add_stake :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Tez_repr.t ->\n Raw_context.t tzresult Lwt.t\n\nval set_inactive :\n Raw_context.t -> Signature.Public_key_hash.t -> Raw_context.t Lwt.t\n\nval set_active :\n Raw_context.t -> Signature.Public_key_hash.t -> Raw_context.t tzresult Lwt.t\n\nval get_staking_balance :\n Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t\n\nval snapshot : Raw_context.t -> Raw_context.t tzresult Lwt.t\n\n(** [fold ctxt ~f ~order init] folds [f] on the list of active delegates having the\n minimal required stake. The folding process starts with [init]. Each element of the\n list is a pair [pkh, stake], where [pkh] is the public key hash of the\n delegate and [stake] is the staking balance of the delegate. *)\nval fold :\n Raw_context.t ->\n f:(Signature.Public_key_hash.t * Tez_repr.t -> 'a -> 'a tzresult Lwt.t) ->\n order:[`Sorted | `Undefined] ->\n 'a ->\n 'a tzresult Lwt.t\n\n(** [fold_snapshot ctxt ~index ~f ~init] folds [f] on the list of active\n delegates having the minimal required stake for the given snapshot [index]. The folding\n process starts with [init]. Each element of the list is a pair [pkh, stake],\n where [pkh] is the public key hash of the delegate and [stake] is the staking\n balance of the delegate for the given snapshot [index]. *)\nval fold_snapshot :\n Raw_context.t ->\n index:int ->\n f:(Signature.Public_key_hash.t * Tez_repr.t -> 'a -> 'a tzresult Lwt.t) ->\n init:'a ->\n 'a tzresult Lwt.t\n\n(** [max_snapshot_index ctxt] returns the index of the last snapshot taken of\n staking balances and active delegates. *)\nval max_snapshot_index : Raw_context.t -> int tzresult Lwt.t\n\n(** [set_selected_distribution_for_cycle ctxt cycle distrib total_stake] saves\n the selected distribution [distrib] of the [total_stake] for the given\n [cycle]. *)\nval set_selected_distribution_for_cycle :\n Raw_context.t ->\n Cycle_repr.t ->\n (Signature.public_key_hash * Tez_repr.t) list ->\n Tez_repr.t ->\n Raw_context.t tzresult Lwt.t\n\nval clear_at_cycle_end :\n Raw_context.t -> new_cycle:Cycle_repr.t -> Raw_context.t tzresult Lwt.t\n\nval get :\n Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t\n\nval fold_on_active_delegates_with_minimal_stake :\n Raw_context.t ->\n order:[`Sorted | `Undefined] ->\n init:'a ->\n f:(Signature.Public_key_hash.t -> unit -> 'a -> 'a Lwt.t) ->\n 'a Lwt.t\n\nval get_selected_distribution :\n Raw_context.t ->\n Cycle_repr.t ->\n (Signature.Public_key_hash.t * Tez_repr.t) list tzresult Lwt.t\n\nval find_selected_distribution :\n Raw_context.t ->\n Cycle_repr.t ->\n (Signature.Public_key_hash.t * Tez_repr.t) list option tzresult Lwt.t\n\n(** Copy the stake distribution for the current cycle (from\n [Storage.Stake.Selected_distribution_for_cycle]) in the raw\n context. *)\nval prepare_stake_distribution : Raw_context.t -> Raw_context.t tzresult Lwt.t\n\n(** [get_total_active_stake ctxt cycle] retrieves the amount in Tez of the\n active stake at [cycle] from [ctxt]. *)\nval get_total_active_stake :\n Raw_context.t -> Cycle_repr.t -> Tez_repr.t tzresult Lwt.t\n\n(** [add_contract_stake ctxt contract amount] calls\n [Stake_storage.add_stake ctxt delegate amount] if [contract] has a\n [delegate]. Otherwise this function does nothing. *)\nval add_contract_stake :\n Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t\n\n(** [remove_contract_stake ctxt contract amount] calls\n [Stake_storage.remove_stake ctxt delegate amount] if [contract] has a\n [delegate]. Otherwise this function does nothing. *)\nval remove_contract_stake :\n Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule Selected_distribution_for_cycle = struct\n module Cache_client = struct\n type cached_value = (Signature.Public_key_hash.t * Tez_repr.t) list\n\n let namespace = Cache_repr.create_namespace \"stake_distribution\"\n\n let cache_index = 1\n\n let value_of_identifier ctxt identifier =\n let cycle = Cycle_repr.of_string_exn identifier in\n Storage.Stake.Selected_distribution_for_cycle.get ctxt cycle\n end\n\n module Cache = (val Cache_repr.register_exn (module Cache_client))\n\n let identifier_of_cycle cycle = Format.asprintf \"%a\" Cycle_repr.pp cycle\n\n let init ctxt cycle stakes =\n let id = identifier_of_cycle cycle in\n Storage.Stake.Selected_distribution_for_cycle.init ctxt cycle stakes\n >>=? fun ctxt ->\n let size = 1 (* that's symbolic: 1 cycle = 1 entry *) in\n Cache.update ctxt id (Some (stakes, size)) >>?= fun ctxt -> return ctxt\n\n let get ctxt cycle =\n let id = identifier_of_cycle cycle in\n Cache.find ctxt id >>=? function\n | None -> Storage.Stake.Selected_distribution_for_cycle.get ctxt cycle\n | Some v -> return v\n\n let remove_existing ctxt cycle =\n let id = identifier_of_cycle cycle in\n Cache.update ctxt id None >>?= fun ctxt ->\n Storage.Stake.Selected_distribution_for_cycle.remove_existing ctxt cycle\nend\n\nlet get_staking_balance = Storage.Stake.Staking_balance.get\n\nlet get_initialized_stake ctxt delegate =\n Storage.Stake.Staking_balance.find ctxt delegate >>=? function\n | Some staking_balance -> return (staking_balance, ctxt)\n | None ->\n Frozen_deposits_storage.init ctxt delegate >>=? fun ctxt ->\n let balance = Tez_repr.zero in\n Storage.Stake.Staking_balance.init ctxt delegate balance >>=? fun ctxt ->\n return (balance, ctxt)\n\nlet remove_stake ctxt delegate amount =\n get_initialized_stake ctxt delegate >>=? fun (staking_balance_before, ctxt) ->\n Tez_repr.(staking_balance_before -? amount) >>?= fun staking_balance ->\n Storage.Stake.Staking_balance.update ctxt delegate staking_balance\n >>=? fun ctxt ->\n let minimal_stake = Constants_storage.minimal_stake ctxt in\n if Tez_repr.(staking_balance_before >= minimal_stake) then\n Delegate_activation_storage.is_inactive ctxt delegate >>=? fun inactive ->\n if (not inactive) && Tez_repr.(staking_balance < minimal_stake) then\n Storage.Stake.Active_delegates_with_minimal_stake.remove ctxt delegate\n >>= fun ctxt -> return ctxt\n else return ctxt\n else\n (* The delegate was not in Stake.Active_delegates_with_minimal_stake,\n either because it was inactive, or because it did not have a\n the minimal required stake, in which case it still does not have it. *)\n return ctxt\n\nlet add_stake ctxt delegate amount =\n get_initialized_stake ctxt delegate >>=? fun (staking_balance_before, ctxt) ->\n Tez_repr.(amount +? staking_balance_before) >>?= fun staking_balance ->\n Storage.Stake.Staking_balance.update ctxt delegate staking_balance\n >>=? fun ctxt ->\n let minimal_stake = Constants_storage.minimal_stake ctxt in\n if Tez_repr.(staking_balance >= minimal_stake) then\n Delegate_activation_storage.is_inactive ctxt delegate >>=? fun inactive ->\n if inactive || Tez_repr.(staking_balance_before >= minimal_stake) then\n return ctxt\n else\n Storage.Stake.Active_delegates_with_minimal_stake.add ctxt delegate ()\n >>= fun ctxt -> return ctxt\n else\n (* The delegate was not in Stake.Active_delegates_with_minimal_stake,\n because it did not have the minimal required stake (as otherwise it\n would also have it now). *)\n return ctxt\n\nlet set_inactive ctxt delegate =\n Delegate_activation_storage.set_inactive ctxt delegate >>= fun ctxt ->\n Storage.Stake.Active_delegates_with_minimal_stake.remove ctxt delegate\n\nlet set_active ctxt delegate =\n Delegate_activation_storage.set_active ctxt delegate\n >>=? fun (ctxt, inactive) ->\n if not inactive then return ctxt\n else\n get_initialized_stake ctxt delegate >>=? fun (staking_balance, ctxt) ->\n let minimal_stake = Constants_storage.minimal_stake ctxt in\n if Tez_repr.(staking_balance >= minimal_stake) then\n Storage.Stake.Active_delegates_with_minimal_stake.add ctxt delegate ()\n >>= fun ctxt -> return ctxt\n else return ctxt\n\nlet snapshot ctxt =\n Storage.Stake.Last_snapshot.get ctxt >>=? fun index ->\n Storage.Stake.Last_snapshot.update ctxt (index + 1) >>=? fun ctxt ->\n Storage.Stake.Staking_balance.snapshot ctxt index >>=? fun ctxt ->\n Storage.Stake.Active_delegates_with_minimal_stake.snapshot ctxt index\n\nlet max_snapshot_index = Storage.Stake.Last_snapshot.get\n\nlet set_selected_distribution_for_cycle ctxt cycle stakes total_stake =\n let stakes = List.sort (fun (_, x) (_, y) -> Tez_repr.compare y x) stakes in\n Selected_distribution_for_cycle.init ctxt cycle stakes >>=? fun ctxt ->\n Storage.Stake.Total_active_stake.add ctxt cycle total_stake >>= fun ctxt ->\n (* cleanup snapshots *)\n Storage.Stake.Staking_balance.Snapshot.clear ctxt >>= fun ctxt ->\n Storage.Stake.Active_delegates_with_minimal_stake.Snapshot.clear ctxt\n >>= fun ctxt -> Storage.Stake.Last_snapshot.update ctxt 0\n\nlet clear_cycle ctxt cycle =\n Storage.Stake.Total_active_stake.remove_existing ctxt cycle >>=? fun ctxt ->\n Selected_distribution_for_cycle.remove_existing ctxt cycle\n\nlet fold ctxt ~f ~order init =\n Storage.Stake.Active_delegates_with_minimal_stake.fold\n ctxt\n ~order\n ~init:(Ok init)\n ~f:(fun delegate () acc ->\n acc >>?= fun acc ->\n get_staking_balance ctxt delegate >>=? fun stake ->\n f (delegate, stake) acc)\n\nlet fold_snapshot ctxt ~index ~f ~init =\n Storage.Stake.Active_delegates_with_minimal_stake.fold_snapshot\n ctxt\n index\n ~order:`Sorted\n ~init\n ~f:(fun delegate () acc ->\n Storage.Stake.Staking_balance.Snapshot.get ctxt (index, delegate)\n >>=? fun stake -> f (delegate, stake) acc)\n\nlet clear_at_cycle_end ctxt ~new_cycle =\n let max_slashing_period = Constants_storage.max_slashing_period ctxt in\n match Cycle_repr.sub new_cycle max_slashing_period with\n | None -> return ctxt\n | Some cycle_to_clear -> clear_cycle ctxt cycle_to_clear\n\nlet get ctxt delegate =\n Storage.Stake.Active_delegates_with_minimal_stake.mem ctxt delegate\n >>= function\n | true -> get_staking_balance ctxt delegate\n | false -> return Tez_repr.zero\n\nlet fold_on_active_delegates_with_minimal_stake =\n Storage.Stake.Active_delegates_with_minimal_stake.fold\n\nlet get_selected_distribution = Selected_distribution_for_cycle.get\n\nlet find_selected_distribution =\n Storage.Stake.Selected_distribution_for_cycle.find\n\nlet prepare_stake_distribution ctxt =\n let level = Level_storage.current ctxt in\n Selected_distribution_for_cycle.get ctxt level.cycle >>=? fun stakes ->\n let stake_distribution =\n List.fold_left\n (fun map (pkh, stake) -> Signature.Public_key_hash.Map.add pkh stake map)\n Signature.Public_key_hash.Map.empty\n stakes\n in\n return\n (Raw_context.init_stake_distribution_for_current_cycle\n ctxt\n stake_distribution)\n\nlet get_total_active_stake = Storage.Stake.Total_active_stake.get\n\nlet remove_contract_stake ctxt contract amount =\n Contract_delegate_storage.find ctxt contract >>=? function\n | None -> return ctxt\n | Some delegate -> remove_stake ctxt delegate amount\n\nlet add_contract_stake ctxt contract amount =\n Contract_delegate_storage.find ctxt contract >>=? function\n | None -> return ctxt\n | Some delegate -> add_stake ctxt delegate amount\n" ;
} ;
{ name = "Contract_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Low-level handlers of raw contexts for base operations on\n contracts. *)\n\ntype error +=\n | (* `Temporary *)\n Balance_too_low of Contract_repr.t * Tez_repr.t * Tez_repr.t\n | (* `Temporary *)\n Counter_in_the_past of {\n contract : Contract_repr.t;\n expected : Manager_counter_repr.t;\n found : Manager_counter_repr.t;\n }\n | (* `Branch *)\n Counter_in_the_future of {\n contract : Contract_repr.t;\n expected : Manager_counter_repr.t;\n found : Manager_counter_repr.t;\n }\n | (* `Temporary *)\n Non_existing_contract of Contract_repr.t\n | (* `Permanent *)\n Inconsistent_public_key of\n Signature.Public_key.t * Signature.Public_key.t\n | (* `Permanent *) Failure of string\n | (* `Branch *)\n Empty_implicit_contract of Signature.Public_key_hash.t\n | (* `Branch *)\n Empty_implicit_delegated_contract of\n Signature.Public_key_hash.t\n\n(** [allocated ctxt contract] returns [true] if and only if the\n contract is stored in {!Storage.Contract.Spendable_balance}. *)\nval allocated : Raw_context.t -> Contract_repr.t -> bool Lwt.t\n\n(** [exists ctxt contract] returns [true] if and only if either the\n contract is originated or it is (implicit and) \"allocated\". *)\nval exists : Raw_context.t -> Contract_repr.t -> bool Lwt.t\n\n(** [must_exist ctxt contract] fails with the [Non_existing_contract] error if\n [exists ctxt contract] returns [false]. Even though this function is\n gas-free, it is always called in a context where some gas consumption is\n guaranteed whenever necessary. The first context is that of a transfer\n operation, and in that case the base cost of a manager operation\n ([Micheclson_v1_gas.Cost_of.manager_operation]) is consumed. The second\n context is that of an activation operation, and in that case no gas needs to\n be consumed since that operation is not a manager operation. *)\nval must_exist : Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t\n\n(** [must_be_allocated ctxt contract] fails when the contract is not\n allocated. It fails with [Non_existing_contract] if the contract is\n originated, and it fails with [Empty_implicit_contract] if the\n contract is implicit. *)\nval must_be_allocated : Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t\n\nval list : Raw_context.t -> Contract_repr.t list Lwt.t\n\nval check_counter_increment :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Manager_counter_repr.t ->\n unit tzresult Lwt.t\n\nval increment_counter :\n Raw_context.t -> Signature.Public_key_hash.t -> Raw_context.t tzresult Lwt.t\n\n(** [get_balance ctxt contract] returns the balance of spendable tez owned by\n [contract] given raw context [ctxt]. This does not include the contract's\n frozen balances. *)\nval get_balance : Raw_context.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t\n\nval get_balance_carbonated :\n Raw_context.t ->\n Contract_repr.t ->\n (Raw_context.t * Tez_repr.t) tzresult Lwt.t\n\n(** Return the balance of spendable tez owned by the Implicit contract\n of the given [public_key_hash].\n\n @return [Error Empty_implicit_contract] if the contract is not\n allocated in {!Storage.Contract.Spendable_balance}.\n\n This function is a fusion of {!must_be_allocated} and\n {!get_balance} for Implicit contracts exclusively. *)\nval check_allocated_and_get_balance :\n Raw_context.t -> Signature.public_key_hash -> Tez_repr.t tzresult Lwt.t\n\nval get_counter :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Manager_counter_repr.t tzresult Lwt.t\n\nval get_script_code :\n Raw_context.t ->\n Contract_hash.t ->\n (Raw_context.t * Script_repr.lazy_expr option) tzresult Lwt.t\n\nval get_script :\n Raw_context.t ->\n Contract_hash.t ->\n (Raw_context.t * Script_repr.t option) tzresult Lwt.t\n\nval get_storage :\n Raw_context.t ->\n Contract_hash.t ->\n (Raw_context.t * Script_repr.expr option) tzresult Lwt.t\n\nmodule Legacy_big_map_diff : sig\n type item = private\n | Update of {\n big_map : Z.t;\n diff_key : Script_repr.expr;\n diff_key_hash : Script_expr_hash.t;\n diff_value : Script_repr.expr option;\n }\n | Clear of Z.t\n | Copy of {src : Z.t; dst : Z.t}\n | Alloc of {\n big_map : Z.t;\n key_type : Script_repr.expr;\n value_type : Script_repr.expr;\n }\n\n type t = item list\n\n val encoding : t Data_encoding.t\n\n val to_lazy_storage_diff : t -> Lazy_storage_diff.diffs\n\n val of_lazy_storage_diff : Lazy_storage_diff.diffs -> t\nend\n\nval update_script_storage :\n Raw_context.t ->\n Contract_hash.t ->\n Script_repr.expr ->\n Lazy_storage_diff.diffs option ->\n Raw_context.t tzresult Lwt.t\n\nval credit_only_call_from_token :\n Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t\n\nval spend_only_call_from_token :\n Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t\n\n(** [raw_originate ctxt ~prepaid_bootstrap_storage contract ~script]\n originates the [contract] parameter. The [storage] space allocated by this\n origination is considered to be free of charge or to have been already paid\n for by the user, if and only if [prepaid_bootstrap_storage] is [true]. In\n particular, the amount of space allocated by this origination will be part\n of the consumed space to pay for returned by the next call to\n [Fees_storage.record_paid_storage_space ctxt contract], if and only if\n [prepaid_bootstrap_storage] is [false]. *)\nval raw_originate :\n Raw_context.t ->\n prepaid_bootstrap_storage:bool ->\n Contract_hash.t ->\n script:Script_repr.t * Lazy_storage_diff.diffs option ->\n Raw_context.t tzresult Lwt.t\n\nval fresh_contract_from_current_nonce :\n Raw_context.t -> (Raw_context.t * Contract_hash.t) tzresult\n\nval originated_from_current_nonce :\n since:Raw_context.t ->\n until:Raw_context.t ->\n Contract_hash.t list tzresult Lwt.t\n\nval init : Raw_context.t -> Raw_context.t tzresult Lwt.t\n\nval used_storage_space : Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t\n\nval paid_storage_space : Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t\n\nval set_paid_storage_space_and_return_fees_to_pay :\n Raw_context.t ->\n Contract_repr.t ->\n Z.t ->\n (Z.t * Raw_context.t) tzresult Lwt.t\n\n(** Enable a payer to increase the paid storage of a contract by some amount. *)\nval increase_paid_storage :\n Raw_context.t ->\n Contract_hash.t ->\n amount_in_bytes:Z.t ->\n Raw_context.t tzresult Lwt.t\n\n(** Increases the balance of a contract. Calling this function directly may\n break important invariants. Consider calling [credit] instead. *)\nval increase_balance_only_call_from_token :\n Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t\n\n(** Decreases the balance of a contract. Calling this function directly may\n break important invariants. Consider calling [spend] instead. *)\nval decrease_balance_only_call_from_token :\n Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t\n\n(** [get_balance_and_frozen_bonds ctxt contract] returns the sum of the\n (spendable) balance and the frozen bonds associated to [contract]. *)\nval get_balance_and_frozen_bonds :\n Raw_context.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t\n\n(** This error is raised when [spend_bond_only_call_from_token] is called with\n an amount that is not equal to the deposit associated to the given contract\n and bond id. *)\ntype error +=\n | (* `Permanent *)\n Frozen_bonds_must_be_spent_at_once of\n Contract_repr.t * Bond_id_repr.t\n\n(** [bond_allocated ctxt contract bond_id] returns a new context because of an\n access to carbonated data, and [true] if there is a bond associated to\n [contract] and [bond_id], or [false] otherwise. *)\nval bond_allocated :\n Raw_context.t ->\n Contract_repr.t ->\n Bond_id_repr.t ->\n (Raw_context.t * bool) tzresult Lwt.t\n\n(** [find_bond ctxt contract bond_id] returns a new context because of an access\n to carbonated data, and the bond associated to [(contract, bond_id)] if\n there is one, or [None] otherwise. *)\nval find_bond :\n Raw_context.t ->\n Contract_repr.t ->\n Bond_id_repr.t ->\n (Raw_context.t * Tez_repr.t option) tzresult Lwt.t\n\n(** [spend_bond ctxt contract bond_id amount] withdraws the given [amount] from\n the value of the bond associated to [contract] and [bond_id].\n\n The argument [amount] is required to be strictly positive.\n\n @raise a [Storage_Error Missing_key] error when there is no bond associated\n to [contract] and [bond_id].\n\n @raise a [Frozen_bonds_must_be_spent_at_once (contract, bond_id)]\n error when the amount is different from the bond associated to [contract]\n and [bond_id]. *)\nval spend_bond_only_call_from_token :\n Raw_context.t ->\n Contract_repr.t ->\n Bond_id_repr.t ->\n Tez_repr.t ->\n Raw_context.t tzresult Lwt.t\n\n(** [credit_bond ctxt contract bond_id amount] adds the given [amount] to the\n bond associated to [contract] and [bond_id]. If no bond exists, one whose\n value is [amount] is created.\n\n The argument [amount] is required to be strictly positive.\n\n @raise a [Addition_overflow] error when\n [(find ctxt contract bond_id) + amount > Int64.max_int]. *)\nval credit_bond_only_call_from_token :\n Raw_context.t ->\n Contract_repr.t ->\n Bond_id_repr.t ->\n Tez_repr.t ->\n Raw_context.t tzresult Lwt.t\n\n(** [has_frozen_bonds ctxt contract] returns [true] if there are frozen bonds\n associated to [contract], and returns [false] otherwise. *)\nval has_frozen_bonds : Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t\n\n(** [get_frozen_bonds ctxt contract] returns the total amount of bonds associated\n to [contract]. *)\nval get_frozen_bonds :\n Raw_context.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t\n\n(** [fold_on_bond_ids ctxt contract order init f] folds [f] on all bond\n identifiers associated to [contract]. *)\nval fold_on_bond_ids :\n Raw_context.t ->\n Contract_repr.t ->\n order:[`Sorted | `Undefined] ->\n init:'a ->\n f:(Bond_id_repr.t -> 'a -> 'a Lwt.t) ->\n 'a Lwt.t\n\n(** [ensure_deallocated_if_empty ctxt contract] de-allocates [contract] if its\n full balance is zero, and it does not delegate. *)\nval ensure_deallocated_if_empty :\n Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t\n\n(** [simulate_spending ctxt ~balance ~amount source] removes [amount]\n from [balance] as if it were the balance of the implicit contract\n associated with [source]. It returns the resulting [new_balance],\n and a boolean [still_allocated] that indicates whether this\n contract would still exist.\n\n [still_allocated] is always [true] when [new_balance] is\n positive. When [new_balance] is zero, it depends on the contract's\n delegated status and frozen bonds (cf {!spend_only_call_from_token}\n and {!ensure_deallocated_if_empty}).\n\n Note that this function does not retrieve the actual balance of\n the contract, nor does it update or delete it. Indeed, its purpose\n is to simulate the spending of fees when validating operations,\n without actually spending them.\n\n @return [Error Balance_too_low] if [balance] is smaller than\n [amount].\n\n @return [Error Empty_implicit_delegated_contract] if [new_balance]\n would be zero and the contract has a delegate that is not the\n contract's own manager. *)\nval simulate_spending :\n Raw_context.t ->\n balance:Tez_repr.t ->\n amount:Tez_repr.t ->\n Signature.public_key_hash ->\n (Tez_repr.t * bool) tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2019-2020 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error +=\n | (* `Temporary *)\n Balance_too_low of Contract_repr.t * Tez_repr.t * Tez_repr.t\n | (* `Temporary *)\n Counter_in_the_past of {\n contract : Contract_repr.t;\n expected : Manager_counter_repr.t;\n found : Manager_counter_repr.t;\n }\n | (* `Branch *)\n Counter_in_the_future of {\n contract : Contract_repr.t;\n expected : Manager_counter_repr.t;\n found : Manager_counter_repr.t;\n }\n | (* `Temporary *)\n Non_existing_contract of Contract_repr.t\n | (* `Branch *)\n Empty_implicit_contract of Signature.Public_key_hash.t\n | (* `Branch *)\n Empty_implicit_delegated_contract of\n Signature.Public_key_hash.t\n | (* `Permanent *)\n Inconsistent_public_key of\n Signature.Public_key.t * Signature.Public_key.t\n | (* `Permanent *) Failure of string\n\ntype error +=\n | (* `Permanent *)\n Frozen_bonds_must_be_spent_at_once of\n Contract_repr.t * Bond_id_repr.t\n\nlet () =\n register_error_kind\n `Temporary\n ~id:\"contract.balance_too_low\"\n ~title:\"Balance too low\"\n ~description:\"An operation tried to spend more tokens than the contract has\"\n ~pp:(fun ppf (c, b, a) ->\n Format.fprintf\n ppf\n \"Balance of contract %a too low (%a) to spend %a\"\n Contract_repr.pp\n c\n Tez_repr.pp\n b\n Tez_repr.pp\n a)\n Data_encoding.(\n obj3\n (req \"contract\" Contract_repr.encoding)\n (req \"balance\" Tez_repr.encoding)\n (req \"amount\" Tez_repr.encoding))\n (function Balance_too_low (c, b, a) -> Some (c, b, a) | _ -> None)\n (fun (c, b, a) -> Balance_too_low (c, b, a)) ;\n register_error_kind\n `Temporary\n ~id:\"contract.counter_in_the_future\"\n ~title:\"Invalid counter (not yet reached) in a manager operation\"\n ~description:\"An operation assumed a contract counter in the future\"\n ~pp:(fun ppf (contract, exp, found) ->\n Format.fprintf\n ppf\n \"Counter %a not yet reached for contract %a (expected %a)\"\n Manager_counter_repr.pp\n found\n Contract_repr.pp\n contract\n Manager_counter_repr.pp\n exp)\n Data_encoding.(\n obj3\n (req \"contract\" Contract_repr.encoding)\n (req \"expected\" Manager_counter_repr.encoding_for_errors)\n (req \"found\" Manager_counter_repr.encoding_for_errors))\n (function\n | Counter_in_the_future {contract; expected; found} ->\n Some (contract, expected, found)\n | _ -> None)\n (fun (contract, expected, found) ->\n Counter_in_the_future {contract; expected; found}) ;\n register_error_kind\n `Branch\n ~id:\"contract.counter_in_the_past\"\n ~title:\"Invalid counter (already used) in a manager operation\"\n ~description:\"An operation assumed a contract counter in the past\"\n ~pp:(fun ppf (contract, exp, found) ->\n Format.fprintf\n ppf\n \"Counter %a already used for contract %a (expected %a)\"\n Manager_counter_repr.pp\n found\n Contract_repr.pp\n contract\n Manager_counter_repr.pp\n exp)\n Data_encoding.(\n obj3\n (req \"contract\" Contract_repr.encoding)\n (req \"expected\" Manager_counter_repr.encoding_for_errors)\n (req \"found\" Manager_counter_repr.encoding_for_errors))\n (function\n | Counter_in_the_past {contract; expected; found} ->\n Some (contract, expected, found)\n | _ -> None)\n (fun (contract, expected, found) ->\n Counter_in_the_past {contract; expected; found}) ;\n register_error_kind\n `Temporary\n ~id:\"contract.non_existing_contract\"\n ~title:\"Non existing contract\"\n ~description:\n \"A contract handle is not present in the context (either it never was or \\\n it has been destroyed)\"\n ~pp:(fun ppf contract ->\n Format.fprintf ppf \"Contract %a does not exist\" Contract_repr.pp contract)\n Data_encoding.(obj1 (req \"contract\" Contract_repr.encoding))\n (function Non_existing_contract c -> Some c | _ -> None)\n (fun c -> Non_existing_contract c) ;\n register_error_kind\n `Permanent\n ~id:\"contract.manager.inconsistent_public_key\"\n ~title:\"Inconsistent public key\"\n ~description:\n \"A provided manager public key is different with the public key stored \\\n in the contract\"\n ~pp:(fun ppf (eh, ph) ->\n Format.fprintf\n ppf\n \"Expected manager public key %s but %s was provided\"\n (Signature.Public_key.to_b58check ph)\n (Signature.Public_key.to_b58check eh))\n Data_encoding.(\n obj2\n (req \"public_key\" Signature.Public_key.encoding)\n (req \"expected_public_key\" Signature.Public_key.encoding))\n (function Inconsistent_public_key (eh, ph) -> Some (eh, ph) | _ -> None)\n (fun (eh, ph) -> Inconsistent_public_key (eh, ph)) ;\n register_error_kind\n `Permanent\n ~id:\"contract.failure\"\n ~title:\"Contract storage failure\"\n ~description:\"Unexpected contract storage error\"\n ~pp:(fun ppf s -> Format.fprintf ppf \"Contract_storage.Failure %S\" s)\n Data_encoding.(obj1 (req \"message\" @@ string Plain))\n (function Failure s -> Some s | _ -> None)\n (fun s -> Failure s) ;\n register_error_kind\n `Branch\n ~id:\"implicit.empty_implicit_contract\"\n ~title:\"Empty implicit contract\"\n ~description:\n \"No manager operations are allowed on an empty implicit contract.\"\n ~pp:(fun ppf implicit ->\n Format.fprintf\n ppf\n \"Empty implicit contract (%a)\"\n Signature.Public_key_hash.pp\n implicit)\n Data_encoding.(obj1 (req \"implicit\" Signature.Public_key_hash.encoding))\n (function Empty_implicit_contract c -> Some c | _ -> None)\n (fun c -> Empty_implicit_contract c) ;\n register_error_kind\n `Branch\n ~id:\"implicit.empty_implicit_delegated_contract\"\n ~title:\"Empty implicit delegated contract\"\n ~description:\"Emptying an implicit delegated account is not allowed.\"\n ~pp:(fun ppf implicit ->\n Format.fprintf\n ppf\n \"Emptying implicit delegated contract (%a)\"\n Signature.Public_key_hash.pp\n implicit)\n Data_encoding.(obj1 (req \"implicit\" Signature.Public_key_hash.encoding))\n (function Empty_implicit_delegated_contract c -> Some c | _ -> None)\n (fun c -> Empty_implicit_delegated_contract c) ;\n register_error_kind\n `Permanent\n ~id:\"frozen_bonds.must_be_spent_at_once\"\n ~title:\"Partial spending of frozen bonds\"\n ~description:\"Frozen bonds must be spent at once.\"\n ~pp:(fun ppf (contract, bond_id) ->\n Format.fprintf\n ppf\n \"The frozen funds for contract (%a) and bond (%a) are not allowed to \\\n be partially withdrawn. The amount withdrawn must be equal to the \\\n entire deposit for the said bond.\"\n Contract_repr.pp\n contract\n Bond_id_repr.pp\n bond_id)\n Data_encoding.(\n obj2\n (req \"contract\" Contract_repr.encoding)\n (req \"bond_id\" Bond_id_repr.encoding))\n (function\n | Frozen_bonds_must_be_spent_at_once (c, b) -> Some (c, b) | _ -> None)\n (fun (c, b) -> Frozen_bonds_must_be_spent_at_once (c, b))\n\nlet failwith msg = tzfail (Failure msg)\n\nmodule Legacy_big_map_diff = struct\n (*\n Big_map_diff receipt as it was represented in 006 and earlier.\n It is kept here for now for backward compatibility of tools. *)\n\n type item =\n | Update of {\n big_map : Z.t;\n diff_key : Script_repr.expr;\n diff_key_hash : Script_expr_hash.t;\n diff_value : Script_repr.expr option;\n }\n | Clear of Z.t\n | Copy of {src : Z.t; dst : Z.t}\n | Alloc of {\n big_map : Z.t;\n key_type : Script_repr.expr;\n value_type : Script_repr.expr;\n }\n\n type t = item list\n\n let item_encoding =\n let open Data_encoding in\n union\n [\n case\n (Tag 0)\n ~title:\"update\"\n (obj5\n (req \"action\" (constant \"update\"))\n (req \"big_map\" z)\n (req \"key_hash\" Script_expr_hash.encoding)\n (req \"key\" Script_repr.expr_encoding)\n (opt \"value\" Script_repr.expr_encoding))\n (function\n | Update {big_map; diff_key_hash; diff_key; diff_value} ->\n Some ((), big_map, diff_key_hash, diff_key, diff_value)\n | _ -> None)\n (fun ((), big_map, diff_key_hash, diff_key, diff_value) ->\n Update {big_map; diff_key_hash; diff_key; diff_value});\n case\n (Tag 1)\n ~title:\"remove\"\n (obj2 (req \"action\" (constant \"remove\")) (req \"big_map\" z))\n (function Clear big_map -> Some ((), big_map) | _ -> None)\n (fun ((), big_map) -> Clear big_map);\n case\n (Tag 2)\n ~title:\"copy\"\n (obj3\n (req \"action\" (constant \"copy\"))\n (req \"source_big_map\" z)\n (req \"destination_big_map\" z))\n (function Copy {src; dst} -> Some ((), src, dst) | _ -> None)\n (fun ((), src, dst) -> Copy {src; dst});\n case\n (Tag 3)\n ~title:\"alloc\"\n (obj4\n (req \"action\" (constant \"alloc\"))\n (req \"big_map\" z)\n (req \"key_type\" Script_repr.expr_encoding)\n (req \"value_type\" Script_repr.expr_encoding))\n (function\n | Alloc {big_map; key_type; value_type} ->\n Some ((), big_map, key_type, value_type)\n | _ -> None)\n (fun ((), big_map, key_type, value_type) ->\n Alloc {big_map; key_type; value_type});\n ]\n\n let encoding = Data_encoding.list item_encoding\n\n let to_lazy_storage_diff legacy_diffs =\n let rev_head (diffs : (_ * (_, _, _) Lazy_storage_diff.diff) list) =\n match diffs with\n | [] -> []\n | (_, Remove) :: _ -> diffs\n | (id, Update {init; updates}) :: rest ->\n (id, Update {init; updates = List.rev updates}) :: rest\n in\n (* Invariant:\n Updates are collected one by one, in reverse order, on the head diff\n item. So only and exactly the head diff item has its updates reversed.\n *)\n List.fold_left\n (fun (new_diff : (_ * (_, _, _) Lazy_storage_diff.diff) list) item ->\n match item with\n | Clear id -> (id, Lazy_storage_diff.Remove) :: rev_head new_diff\n | Copy {src; dst} ->\n let src =\n Lazy_storage_kind.Big_map.Id\n .of_legacy_USE_ONLY_IN_Legacy_big_map_diff\n src\n in\n (dst, Lazy_storage_diff.Update {init = Copy {src}; updates = []})\n :: rev_head new_diff\n | Alloc {big_map; key_type; value_type} ->\n ( big_map,\n Lazy_storage_diff.(\n Update\n {\n init = Alloc Lazy_storage_kind.Big_map.{key_type; value_type};\n updates = [];\n }) )\n :: rev_head new_diff\n | Update\n {\n big_map;\n diff_key = key;\n diff_key_hash = key_hash;\n diff_value = value;\n } -> (\n match new_diff with\n | (id, diff) :: rest when Compare.Z.(id = big_map) ->\n let diff =\n match diff with\n | Remove -> assert false\n | Update {init; updates} ->\n let updates =\n Lazy_storage_kind.Big_map.{key; key_hash; value}\n :: updates\n in\n Lazy_storage_diff.Update {init; updates}\n in\n (id, diff) :: rest\n | new_diff ->\n let updates =\n [Lazy_storage_kind.Big_map.{key; key_hash; value}]\n in\n (big_map, Update {init = Existing; updates})\n :: rev_head new_diff))\n []\n legacy_diffs\n |> rev_head\n |> List.rev_map (fun (id, diff) ->\n let id =\n Lazy_storage_kind.Big_map.Id\n .of_legacy_USE_ONLY_IN_Legacy_big_map_diff\n id\n in\n Lazy_storage_diff.make Lazy_storage_kind.Big_map id diff)\n\n let of_lazy_storage_diff diffs =\n List.fold_left\n (fun legacy_diffs (Lazy_storage_diff.Item (kind, id, diff)) ->\n let diffs =\n match kind with\n | Lazy_storage_kind.Big_map -> (\n let id =\n Lazy_storage_kind.Big_map.Id\n .to_legacy_USE_ONLY_IN_Legacy_big_map_diff\n id\n in\n match diff with\n | Remove -> [Clear id]\n | Update {init; updates} -> (\n let updates =\n List.rev_map\n (fun {Lazy_storage_kind.Big_map.key; key_hash; value} ->\n Update\n {\n big_map = id;\n diff_key = key;\n diff_key_hash = key_hash;\n diff_value = value;\n })\n updates\n in\n match init with\n | Existing -> updates\n | Copy {src} ->\n let src =\n Lazy_storage_kind.Big_map.Id\n .to_legacy_USE_ONLY_IN_Legacy_big_map_diff\n src\n in\n Copy {src; dst = id} :: updates\n | Alloc {key_type; value_type} ->\n Alloc {big_map = id; key_type; value_type} :: updates))\n | _ -> (* Not a Big_map *) []\n in\n diffs :: legacy_diffs)\n []\n diffs\n |> List.rev |> List.flatten\nend\n\nlet update_script_lazy_storage c = function\n | None -> return (c, Z.zero)\n | Some diffs -> Lazy_storage_diff.apply c diffs\n\nlet raw_originate c ~prepaid_bootstrap_storage\n (* Free space for bootstrap contracts *) contract ~script =\n let contract = Contract_repr.Originated contract in\n Storage.Contract.Spendable_balance.init c contract Tez_repr.zero >>=? fun c ->\n let {Script_repr.code; storage}, lazy_storage_diff = script in\n Storage.Contract.Code.init c contract code >>=? fun (c, code_size) ->\n Storage.Contract.Storage.init c contract storage >>=? fun (c, storage_size) ->\n update_script_lazy_storage c lazy_storage_diff\n >>=? fun (c, lazy_storage_size) ->\n let total_size =\n Z.add (Z.add (Z.of_int code_size) (Z.of_int storage_size)) lazy_storage_size\n in\n assert (Compare.Z.(total_size >= Z.zero)) ;\n let prepaid_bootstrap_storage =\n if prepaid_bootstrap_storage then total_size else Z.zero\n in\n Storage.Contract.Paid_storage_space.init c contract prepaid_bootstrap_storage\n >>=? fun c -> Storage.Contract.Used_storage_space.init c contract total_size\n\nlet create_implicit c manager ~balance =\n let contract = Contract_repr.Implicit manager in\n Storage.Contract.Global_counter.get c >>=? fun counter ->\n Storage.Contract.Counter.init c contract counter >>=? fun c ->\n Storage.Contract.Spendable_balance.init c contract balance >>=? fun c ->\n Contract_manager_storage.init c contract (Manager_repr.Hash manager)\n\nlet delete c contract =\n match contract with\n | Contract_repr.Originated _ ->\n (* For non implicit contract Big_map should be cleared *)\n failwith \"Non implicit contracts cannot be removed\"\n | Implicit _ ->\n (* Implicit contract do not have: [Code], [Storage],\n [Paid_storage_space] and [Used_storage_space]. We do not need\n to delete them. Futhermore, these storages space are\n carbonated, thus, require gas to be deleted (even when they\n do not exist). An implicit contract deletion should not cost\n extra gas. *)\n Contract_delegate_storage.unlink c contract >>=? fun c ->\n let update local =\n Storage.Contract.Spendable_balance.Local.remove_existing local\n >>=? fun local ->\n Storage.Contract.Manager.Local.remove_existing local >>=? fun local ->\n Storage.Contract.Counter.Local.remove_existing local\n in\n Storage.Contract.with_local_context c contract (fun local ->\n update local >|=? fun local -> (local, ()))\n >|=? fun (c, ()) -> c\n\nlet allocated c contract = Storage.Contract.Spendable_balance.mem c contract\n\nlet exists c contract =\n match contract with\n | Contract_repr.Implicit _ -> Lwt.return_true\n | Originated _ -> allocated c contract\n\nlet must_exist c contract =\n exists c contract >>= function\n | true -> return_unit\n | false -> tzfail (Non_existing_contract contract)\n\nlet must_be_allocated c contract =\n allocated c contract >>= function\n | true -> return_unit\n | false -> (\n match contract with\n | Implicit pkh -> tzfail (Empty_implicit_contract pkh)\n | Originated _ -> tzfail (Non_existing_contract contract))\n\nlet list c = Storage.Contract.list c\n\nlet fresh_contract_from_current_nonce c =\n Raw_context.increment_origination_nonce c >|? fun (c, nonce) ->\n (c, Contract_hash.of_nonce nonce)\n\nlet originated_from_current_nonce ~since:ctxt_since ~until:ctxt_until =\n Raw_context.get_origination_nonce ctxt_since >>?= fun since ->\n Raw_context.get_origination_nonce ctxt_until >>?= fun until ->\n List.filter_s\n (fun contract -> exists ctxt_until (Contract_repr.Originated contract))\n (Contract_repr.originated_contracts ~since ~until)\n >|= ok\n\nlet check_counter_increment c manager counter =\n let contract = Contract_repr.Implicit manager in\n Storage.Contract.Counter.get c contract >>=? fun contract_counter ->\n let expected = Manager_counter_repr.succ contract_counter in\n if Manager_counter_repr.(expected = counter) then return_unit\n else if Manager_counter_repr.(expected > counter) then\n tzfail (Counter_in_the_past {contract; expected; found = counter})\n else tzfail (Counter_in_the_future {contract; expected; found = counter})\n\nlet increment_counter c manager =\n let contract = Contract_repr.Implicit manager in\n Storage.Contract.Global_counter.get c >>=? fun global_counter ->\n Storage.Contract.Global_counter.update\n c\n (Manager_counter_repr.succ global_counter)\n >>=? fun c ->\n Storage.Contract.Counter.get c contract >>=? fun contract_counter ->\n Storage.Contract.Counter.update\n c\n contract\n (Manager_counter_repr.succ contract_counter)\n\nlet get_script_code c contract_hash =\n let contract = Contract_repr.Originated contract_hash in\n Storage.Contract.Code.find c contract\n\nlet get_script c contract_hash =\n let contract = Contract_repr.Originated contract_hash in\n Storage.Contract.Code.find c contract >>=? fun (c, code) ->\n Storage.Contract.Storage.find c contract >>=? fun (c, storage) ->\n match (code, storage) with\n | None, None -> return (c, None)\n | Some code, Some storage -> return (c, Some {Script_repr.code; storage})\n | None, Some _ | Some _, None -> failwith \"get_script\"\n\nlet get_storage ctxt contract_hash =\n let contract = Contract_repr.Originated contract_hash in\n Storage.Contract.Storage.find ctxt contract >>=? function\n | ctxt, None -> return (ctxt, None)\n | ctxt, Some storage ->\n Raw_context.consume_gas ctxt (Script_repr.force_decode_cost storage)\n >>?= fun ctxt ->\n Script_repr.force_decode storage >>?= fun storage ->\n return (ctxt, Some storage)\n\nlet get_counter c manager =\n let contract = Contract_repr.Implicit manager in\n Storage.Contract.Counter.find c contract >>=? function\n | None -> (\n match contract with\n | Contract_repr.Implicit _ -> Storage.Contract.Global_counter.get c\n | Originated _ -> failwith \"get_counter\")\n | Some v -> return v\n\nlet get_balance c contract =\n Storage.Contract.Spendable_balance.find c contract >>=? function\n | None -> (\n match contract with\n | Implicit _ -> return Tez_repr.zero\n | Originated _ -> failwith \"get_balance\")\n | Some v -> return v\n\nlet get_balance_carbonated c contract =\n (* Reading an int64 from /contracts/index/<hash>/balance *)\n Raw_context.consume_gas\n c\n (Storage_costs.read_access ~path_length:4 ~read_bytes:8)\n >>?= fun c ->\n get_balance c contract >>=? fun balance -> return (c, balance)\n\nlet check_allocated_and_get_balance c pkh =\n let open Lwt_result_syntax in\n let* balance_opt =\n Storage.Contract.Spendable_balance.find c (Contract_repr.Implicit pkh)\n in\n match balance_opt with\n | None -> tzfail (Empty_implicit_contract pkh)\n | Some balance -> return balance\n\nlet update_script_storage c contract_hash storage lazy_storage_diff =\n let contract = Contract_repr.Originated contract_hash in\n let storage = Script_repr.lazy_expr storage in\n update_script_lazy_storage c lazy_storage_diff\n >>=? fun (c, lazy_storage_size_diff) ->\n Storage.Contract.Storage.update c contract storage >>=? fun (c, size_diff) ->\n Storage.Contract.Used_storage_space.get c contract >>=? fun previous_size ->\n let new_size =\n Z.add previous_size (Z.add lazy_storage_size_diff (Z.of_int size_diff))\n in\n Storage.Contract.Used_storage_space.update c contract new_size\n\nlet spend_from_balance contract balance amount =\n record_trace\n (Balance_too_low (contract, balance, amount))\n Tez_repr.(balance -? amount)\n\nlet check_emptiable c contract =\n let open Lwt_result_syntax in\n match contract with\n | Contract_repr.Originated _ -> return_unit\n | Implicit pkh -> (\n let* delegate = Contract_delegate_storage.find c contract in\n match delegate with\n | Some pkh' ->\n if Signature.Public_key_hash.equal pkh pkh' then return_unit\n else\n (* Delegated implicit accounts cannot be emptied *)\n Lwt.return (error (Empty_implicit_delegated_contract pkh))\n | None -> return_unit)\n\nlet spend_only_call_from_token c contract amount =\n let open Lwt_result_syntax in\n let* balance = Storage.Contract.Spendable_balance.find c contract in\n let balance = Option.value balance ~default:Tez_repr.zero in\n let*? new_balance = spend_from_balance contract balance amount in\n let* c = Storage.Contract.Spendable_balance.update c contract new_balance in\n let* c = Stake_storage.remove_contract_stake c contract amount in\n let+ () =\n when_\n Tez_repr.(new_balance <= Tez_repr.zero)\n (fun () -> check_emptiable c contract)\n in\n c\n\n(* [Tez_repr.(amount <> zero)] is a precondition of this function. It ensures that\n no entry associating a null balance to an implicit contract exists in the map\n [Storage.Contract.Spendable_balance]. *)\nlet credit_only_call_from_token c contract amount =\n Storage.Contract.Spendable_balance.find c contract >>=? function\n | None -> (\n match contract with\n | Originated _ -> tzfail (Non_existing_contract contract)\n | Implicit manager -> create_implicit c manager ~balance:amount)\n | Some balance ->\n Tez_repr.(amount +? balance) >>?= fun balance ->\n Storage.Contract.Spendable_balance.update c contract balance >>=? fun c ->\n Stake_storage.add_contract_stake c contract amount\n\nlet init c =\n Storage.Contract.Global_counter.init c Manager_counter_repr.init >>=? fun c ->\n Lazy_storage_diff.init c\n\nlet used_storage_space c contract =\n Storage.Contract.Used_storage_space.find c contract\n >|=? Option.value ~default:Z.zero\n\nlet paid_storage_space c contract =\n Storage.Contract.Paid_storage_space.find c contract\n >|=? Option.value ~default:Z.zero\n\nlet set_paid_storage_space_and_return_fees_to_pay c contract new_storage_space =\n Storage.Contract.Paid_storage_space.get c contract\n >>=? fun already_paid_space ->\n if Compare.Z.(already_paid_space >= new_storage_space) then return (Z.zero, c)\n else\n let to_pay = Z.sub new_storage_space already_paid_space in\n Storage.Contract.Paid_storage_space.update c contract new_storage_space\n >|=? fun c -> (to_pay, c)\n\nlet increase_paid_storage c contract_hash ~amount_in_bytes:storage_incr =\n let contract = Contract_repr.Originated contract_hash in\n Storage.Contract.Paid_storage_space.get c contract\n >>=? fun already_paid_space ->\n let new_storage_space = Z.add already_paid_space storage_incr in\n Storage.Contract.Paid_storage_space.update c contract new_storage_space\n\nlet update_balance ctxt contract f amount =\n Storage.Contract.Spendable_balance.get ctxt contract >>=? fun balance ->\n f balance amount >>?= fun new_balance ->\n Storage.Contract.Spendable_balance.update ctxt contract new_balance\n\nlet increase_balance_only_call_from_token ctxt contract amount =\n update_balance ctxt contract Tez_repr.( +? ) amount\n\nlet decrease_balance_only_call_from_token ctxt contract amount =\n update_balance ctxt contract Tez_repr.( -? ) amount\n\nlet get_frozen_bonds ctxt contract =\n Storage.Contract.Total_frozen_bonds.find ctxt contract\n >|=? Option.value ~default:Tez_repr.zero\n\nlet get_balance_and_frozen_bonds ctxt contract =\n Storage.Contract.Spendable_balance.get ctxt contract >>=? fun balance ->\n get_frozen_bonds ctxt contract >>=? fun total_bonds ->\n Lwt.return Tez_repr.(balance +? total_bonds)\n\nlet bond_allocated ctxt contract bond_id =\n Storage.Contract.Frozen_bonds.mem (ctxt, contract) bond_id\n\nlet find_bond ctxt contract bond_id =\n Storage.Contract.Frozen_bonds.find (ctxt, contract) bond_id\n\n(** PRE : [amount > 0], fulfilled by unique caller [Token.transfer]. *)\nlet spend_bond_only_call_from_token ctxt contract bond_id amount =\n fail_when Tez_repr.(amount = zero) (Failure \"Expecting : [amount > 0]\")\n >>=? fun () ->\n Stake_storage.remove_contract_stake ctxt contract amount >>=? fun ctxt ->\n Storage.Contract.Frozen_bonds.get (ctxt, contract) bond_id\n >>=? fun (ctxt, frozen_bonds) ->\n error_when\n Tez_repr.(frozen_bonds <> amount)\n (Frozen_bonds_must_be_spent_at_once (contract, bond_id))\n >>?= fun () ->\n Storage.Contract.Frozen_bonds.remove_existing (ctxt, contract) bond_id\n >>=? fun (ctxt, _) ->\n Storage.Contract.Total_frozen_bonds.get ctxt contract >>=? fun total ->\n Tez_repr.(total -? amount) >>?= fun new_total ->\n if Tez_repr.(new_total = zero) then\n Storage.Contract.Total_frozen_bonds.remove_existing ctxt contract\n else Storage.Contract.Total_frozen_bonds.update ctxt contract new_total\n\n(** PRE : [amount > 0], fulfilled by unique caller [Token.transfer]. *)\nlet credit_bond_only_call_from_token ctxt contract bond_id amount =\n fail_when Tez_repr.(amount = zero) (Failure \"Expecting : [amount > 0]\")\n >>=? fun () ->\n Stake_storage.add_contract_stake ctxt contract amount >>=? fun ctxt ->\n ( Storage.Contract.Frozen_bonds.find (ctxt, contract) bond_id\n >>=? fun (ctxt, frozen_bonds_opt) ->\n match frozen_bonds_opt with\n | None -> Storage.Contract.Frozen_bonds.init (ctxt, contract) bond_id amount\n | Some frozen_bonds ->\n Tez_repr.(frozen_bonds +? amount) >>?= fun new_amount ->\n Storage.Contract.Frozen_bonds.update (ctxt, contract) bond_id new_amount\n )\n >>=? fun (ctxt, _) ->\n Storage.Contract.Total_frozen_bonds.find ctxt contract >>=? function\n | None -> Storage.Contract.Total_frozen_bonds.init ctxt contract amount\n | Some total ->\n Tez_repr.(total +? amount) >>?= fun new_total ->\n Storage.Contract.Total_frozen_bonds.update ctxt contract new_total\n\nlet has_frozen_bonds ctxt contract =\n Storage.Contract.Total_frozen_bonds.mem ctxt contract >|= ok\n\nlet fold_on_bond_ids ctxt contract =\n Storage.Contract.fold_bond_ids (ctxt, contract)\n\n(** Indicate whether the given implicit contract should avoid deletion\n when it is emptied. *)\nlet should_keep_empty_implicit_contract ctxt contract =\n let open Lwt_result_syntax in\n let* has_frozen_bonds = has_frozen_bonds ctxt contract in\n if has_frozen_bonds then return_true\n else\n (* full balance of contract is zero. *)\n Contract_delegate_storage.find ctxt contract >>=? function\n | Some _ ->\n (* Here, we know that the contract delegates to itself.\n Indeed, it does not delegate to a different one, because\n the balance of such contracts cannot be zero (see\n {!spend_only_call_from_token}), hence the stake of such\n contracts cannot be zero either. *)\n return_true\n | None ->\n (* Delete empty implicit contract. *)\n return_false\n\nlet ensure_deallocated_if_empty ctxt contract =\n let open Lwt_result_syntax in\n match contract with\n | Contract_repr.Originated _ ->\n return ctxt (* Never delete originated contracts *)\n | Implicit _ -> (\n let* balance_opt =\n Storage.Contract.Spendable_balance.find ctxt contract\n in\n match balance_opt with\n | None ->\n (* Nothing to do, contract is not allocated. *)\n return ctxt\n | Some balance ->\n if Tez_repr.(balance <> zero) then return ctxt\n else\n let* keep_contract =\n should_keep_empty_implicit_contract ctxt contract\n in\n if keep_contract then return ctxt else delete ctxt contract)\n\nlet simulate_spending ctxt ~balance ~amount source =\n let open Lwt_result_syntax in\n let contract = Contract_repr.Implicit source in\n let*? new_balance = spend_from_balance contract balance amount in\n let* still_allocated =\n if Tez_repr.(new_balance > zero) then return_true\n else\n let* () = check_emptiable ctxt contract in\n should_keep_empty_implicit_contract ctxt contract\n in\n return (new_balance, still_allocated)\n" ;
} ;
{ name = "Token" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2020-2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** The aim of this module is to manage operations involving tokens such as\n minting, transferring, and burning. Every constructor of the types [source],\n [container], or [sink] represents a kind of account that holds a given (or\n possibly infinite) amount of tokens.\n\n Tokens can be transferred from a [source] to a [sink]. To uniformly handle\n all cases, special constructors of sources and sinks may be used. For\n example, the source [`Minted] is used to express a transfer of minted tokens\n to a destination, and the sink [`Burned] is used to express the action of\n burning a given amount of tokens taken from a source. Thanks to uniformity,\n it is easier to track transfers of tokens throughout the protocol by running\n [grep -R \"Token.transfer\" src/proto_alpha]. *)\n\n(** [container] is the type of token holders with finite capacity, and whose assets\n are contained in the context. Let [d] be a delegate. Be aware that transferring\n to/from [`Delegate_balance d] will not update [d]'s stake, while transferring\n to/from [`Contract (Contract_repr.Implicit d)] will update [d]'s\n stake. *)\n\ntype container =\n [ `Contract of Contract_repr.t\n | `Collected_commitments of Blinded_public_key_hash.t\n | `Delegate_balance of Signature.Public_key_hash.t\n | `Frozen_deposits of Signature.Public_key_hash.t\n | `Block_fees\n | `Frozen_bonds of Contract_repr.t * Bond_id_repr.t ]\n\n(** [infinite_source] defines types of tokens provides which are considered to be\n ** of infinite capacity. *)\ntype infinite_source =\n [ `Invoice\n | `Bootstrap\n | `Initial_commitments\n | `Revelation_rewards\n | `Double_signing_evidence_rewards\n | `Endorsing_rewards\n | `Baking_rewards\n | `Baking_bonuses\n | `Minted\n | `Liquidity_baking_subsidies\n | `Tx_rollup_rejection_rewards\n | `Sc_rollup_refutation_rewards ]\n\n(** [source] is the type of token providers. Token providers that are not\n containers are considered to have infinite capacity. *)\ntype source = [infinite_source | container]\n\ntype infinite_sink =\n [ `Storage_fees\n | `Double_signing_punishments\n | `Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool\n | `Tx_rollup_rejection_punishments\n | `Sc_rollup_refutation_punishments\n | `Burned ]\n\n(** [sink] is the type of token receivers. Token receivers that are not\n containers are considered to have infinite capacity. *)\ntype sink = [infinite_sink | container]\n\n(** [allocated ctxt container] returns a new context because of possible access\n to carbonated data, and a boolean that is [true] when\n [balance ctxt container] is guaranteed not to fail, and [false] when\n [balance ctxt container] may fail. *)\nval allocated :\n Raw_context.t -> container -> (Raw_context.t * bool) tzresult Lwt.t\n\n(** [balance ctxt container] returns a new context because of an access to\n carbonated data, and the balance associated to the token holder.\n This function may fail if [allocated ctxt container] returns [false].\n Returns an error with the message \"get_balance\" if [container] refers to an\n originated contract that is not allocated.\n Returns a {!Storage_Error Missing_key} error if [container] is of the form\n [`Delegate_balance pkh], where [pkh] refers to an implicit contract that is\n not allocated. *)\nval balance :\n Raw_context.t -> container -> (Raw_context.t * Tez_repr.t) tzresult Lwt.t\n\n(** [transfer_n ?origin ctxt sources dest] transfers [amount] Tez from [src] to\n [dest] for each [(src, amount)] pair in [sources], and returns a new\n context, and the list of corresponding balance updates. The function behaves\n as though [transfer src dest amount] was invoked for each pair\n [(src, amount)] in [sources], however a single balance update is generated\n for the total amount transferred to [dest].\n When [sources] is an empty list, the function does nothing to the context,\n and returns an empty list of balance updates. *)\nval transfer_n :\n ?origin:Receipt_repr.update_origin ->\n Raw_context.t ->\n ([< source] * Tez_repr.t) list ->\n [< sink] ->\n (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t\n\n(** [transfer ?origin ctxt src dest amount] transfers [amount] Tez from source\n [src] to destination [dest], and returns a new context, and the list of\n corresponding balance updates tagged with [origin]. By default, [~origin] is\n set to [Receipt_repr.Block_application].\n Returns {!Storage_Error Missing_key} if [src] refers to a contract that is\n not allocated.\n Returns a [Balance_too_low] error if [src] refers to a contract whose\n balance is less than [amount].\n Returns a [Subtraction_underflow] error if [src] refers to a source that is\n not a contract and whose balance is less than [amount].\n Returns a [Empty_implicit_delegated_contract] error if [src] is an\n implicit contract that delegates to a different contract, and whose balance\n is equal to [amount].\n Returns a [Non_existing_contract] error if\n [dest] refers to an originated contract that is not allocated.\n Returns a [Non_existing_contract] error if [amount <> Tez_repr.zero], and\n [dest] refers to an originated contract that is not allocated.\n Returns a [Addition_overflow] error if [dest] refers to a sink whose balance\n is greater than [Int64.max - amount].\n Returns a [Wrong_level] error if [src] or [dest] refer to a level that is\n not the current level. *)\nval transfer :\n ?origin:Receipt_repr.update_origin ->\n Raw_context.t ->\n [< source] ->\n [< sink] ->\n Tez_repr.t ->\n (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2020-2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype container =\n [ `Contract of Contract_repr.t\n | `Collected_commitments of Blinded_public_key_hash.t\n | `Delegate_balance of Signature.Public_key_hash.t\n | `Frozen_deposits of Signature.Public_key_hash.t\n | `Block_fees\n | `Frozen_bonds of Contract_repr.t * Bond_id_repr.t ]\n\ntype infinite_source =\n [ `Invoice\n | `Bootstrap\n | `Initial_commitments\n | `Revelation_rewards\n | `Double_signing_evidence_rewards\n | `Endorsing_rewards\n | `Baking_rewards\n | `Baking_bonuses\n | `Minted\n | `Liquidity_baking_subsidies\n | `Tx_rollup_rejection_rewards\n | `Sc_rollup_refutation_rewards ]\n\ntype source = [infinite_source | container]\n\ntype infinite_sink =\n [ `Storage_fees\n | `Double_signing_punishments\n | `Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool\n | `Tx_rollup_rejection_punishments\n | `Sc_rollup_refutation_punishments\n | `Burned ]\n\ntype sink = [infinite_sink | container]\n\nlet allocated ctxt stored =\n match stored with\n | `Contract contract ->\n Contract_storage.allocated ctxt contract >|= fun allocated ->\n ok (ctxt, allocated)\n | `Collected_commitments bpkh ->\n Commitment_storage.exists ctxt bpkh >|= fun allocated ->\n ok (ctxt, allocated)\n | `Delegate_balance delegate ->\n let contract = Contract_repr.Implicit delegate in\n Contract_storage.allocated ctxt contract >|= fun allocated ->\n ok (ctxt, allocated)\n | `Frozen_deposits delegate ->\n let contract = Contract_repr.Implicit delegate in\n Frozen_deposits_storage.allocated ctxt contract >|= fun allocated ->\n ok (ctxt, allocated)\n | `Block_fees -> return (ctxt, true)\n | `Frozen_bonds (contract, bond_id) ->\n Contract_storage.bond_allocated ctxt contract bond_id\n\nlet balance ctxt stored =\n match stored with\n | `Contract contract ->\n Contract_storage.get_balance ctxt contract >|=? fun balance ->\n (ctxt, balance)\n | `Collected_commitments bpkh ->\n Commitment_storage.committed_amount ctxt bpkh >|=? fun balance ->\n (ctxt, balance)\n | `Delegate_balance delegate ->\n let contract = Contract_repr.Implicit delegate in\n Storage.Contract.Spendable_balance.get ctxt contract >|=? fun balance ->\n (ctxt, balance)\n | `Frozen_deposits delegate ->\n let contract = Contract_repr.Implicit delegate in\n Frozen_deposits_storage.find ctxt contract >|=? fun frozen_deposits ->\n let balance =\n match frozen_deposits with\n | None -> Tez_repr.zero\n | Some frozen_deposits -> frozen_deposits.current_amount\n in\n (ctxt, balance)\n | `Block_fees -> return (ctxt, Raw_context.get_collected_fees ctxt)\n | `Frozen_bonds (contract, bond_id) ->\n Contract_storage.find_bond ctxt contract bond_id\n >|=? fun (ctxt, balance_opt) ->\n (ctxt, Option.value ~default:Tez_repr.zero balance_opt)\n\nlet credit ctxt dest amount origin =\n let open Receipt_repr in\n (match dest with\n | #infinite_sink as infinite_sink ->\n let sink =\n match infinite_sink with\n | `Storage_fees -> Storage_fees\n | `Double_signing_punishments -> Double_signing_punishments\n | `Lost_endorsing_rewards (d, p, r) -> Lost_endorsing_rewards (d, p, r)\n | `Tx_rollup_rejection_punishments -> Tx_rollup_rejection_punishments\n | `Sc_rollup_refutation_punishments -> Sc_rollup_refutation_punishments\n | `Burned -> Burned\n in\n return (ctxt, sink)\n | #container as container -> (\n match container with\n | `Contract dest ->\n Contract_storage.credit_only_call_from_token ctxt dest amount\n >|=? fun ctxt -> (ctxt, Contract dest)\n | `Collected_commitments bpkh ->\n Commitment_storage.increase_commitment_only_call_from_token\n ctxt\n bpkh\n amount\n >|=? fun ctxt -> (ctxt, Commitments bpkh)\n | `Delegate_balance delegate ->\n let contract = Contract_repr.Implicit delegate in\n Contract_storage.increase_balance_only_call_from_token\n ctxt\n contract\n amount\n >|=? fun ctxt -> (ctxt, Contract contract)\n | `Frozen_deposits delegate as dest ->\n allocated ctxt dest >>=? fun (ctxt, allocated) ->\n (if not allocated then Frozen_deposits_storage.init ctxt delegate\n else return ctxt)\n >>=? fun ctxt ->\n Frozen_deposits_storage.credit_only_call_from_token\n ctxt\n delegate\n amount\n >|=? fun ctxt -> (ctxt, Deposits delegate)\n | `Block_fees ->\n Raw_context.credit_collected_fees_only_call_from_token ctxt amount\n >>?= fun ctxt -> return (ctxt, Block_fees)\n | `Frozen_bonds (contract, bond_id) ->\n Contract_storage.credit_bond_only_call_from_token\n ctxt\n contract\n bond_id\n amount\n >>=? fun ctxt -> return (ctxt, Frozen_bonds (contract, bond_id))))\n >|=? fun (ctxt, balance) -> (ctxt, (balance, Credited amount, origin))\n\nlet spend ctxt src amount origin =\n let open Receipt_repr in\n (match src with\n | #infinite_source as infinite_source ->\n let src =\n match infinite_source with\n | `Bootstrap -> Bootstrap\n | `Invoice -> Invoice\n | `Initial_commitments -> Initial_commitments\n | `Minted -> Minted\n | `Liquidity_baking_subsidies -> Liquidity_baking_subsidies\n | `Revelation_rewards -> Nonce_revelation_rewards\n | `Double_signing_evidence_rewards -> Double_signing_evidence_rewards\n | `Endorsing_rewards -> Endorsing_rewards\n | `Baking_rewards -> Baking_rewards\n | `Baking_bonuses -> Baking_bonuses\n | `Tx_rollup_rejection_rewards -> Tx_rollup_rejection_rewards\n | `Sc_rollup_refutation_rewards -> Sc_rollup_refutation_rewards\n in\n return (ctxt, src)\n | #container as container -> (\n match container with\n | `Contract src ->\n Contract_storage.spend_only_call_from_token ctxt src amount\n >|=? fun ctxt -> (ctxt, Contract src)\n | `Collected_commitments bpkh ->\n Commitment_storage.decrease_commitment_only_call_from_token\n ctxt\n bpkh\n amount\n >|=? fun ctxt -> (ctxt, Commitments bpkh)\n | `Delegate_balance delegate ->\n let contract = Contract_repr.Implicit delegate in\n Contract_storage.decrease_balance_only_call_from_token\n ctxt\n contract\n amount\n >|=? fun ctxt -> (ctxt, Contract contract)\n | `Frozen_deposits delegate ->\n Frozen_deposits_storage.spend_only_call_from_token\n ctxt\n delegate\n amount\n >|=? fun ctxt -> (ctxt, Deposits delegate)\n | `Block_fees ->\n Raw_context.spend_collected_fees_only_call_from_token ctxt amount\n >>?= fun ctxt -> return (ctxt, Block_fees)\n | `Frozen_bonds (contract, bond_id) ->\n Contract_storage.spend_bond_only_call_from_token\n ctxt\n contract\n bond_id\n amount\n >>=? fun ctxt -> return (ctxt, Frozen_bonds (contract, bond_id))))\n >|=? fun (ctxt, balance) -> (ctxt, (balance, Debited amount, origin))\n\nlet transfer_n ?(origin = Receipt_repr.Block_application) ctxt src dest =\n let sources = List.filter (fun (_, am) -> Tez_repr.(am <> zero)) src in\n match sources with\n | [] ->\n (* Avoid accessing context data when there is nothing to transfer. *)\n return (ctxt, [])\n | _ :: _ ->\n (* Withdraw from sources. *)\n List.fold_left_es\n (fun (ctxt, total, debit_logs) (source, amount) ->\n spend ctxt source amount origin >>=? fun (ctxt, debit_log) ->\n Tez_repr.(amount +? total) >>?= fun total ->\n return (ctxt, total, debit_log :: debit_logs))\n (ctxt, Tez_repr.zero, [])\n sources\n >>=? fun (ctxt, amount, debit_logs) ->\n credit ctxt dest amount origin >>=? fun (ctxt, credit_log) ->\n (* Deallocate implicit contracts with no stake. This must be done after\n spending and crediting. If done in between then a transfer of all the\n balance from (`Contract c) to (`Frozen_bonds (c,_)) would leave the\n contract c unallocated. *)\n List.fold_left_es\n (fun ctxt (source, _amount) ->\n match source with\n | `Contract contract | `Frozen_bonds (contract, _) ->\n Contract_storage.ensure_deallocated_if_empty ctxt contract\n | #source -> return ctxt)\n ctxt\n sources\n >|=? fun ctxt ->\n (* Make sure the order of balance updates is : debit logs in the order of\n of the parameter [src], and then the credit log. *)\n let balance_updates = List.rev (credit_log :: debit_logs) in\n (ctxt, balance_updates)\n\nlet transfer ?(origin = Receipt_repr.Block_application) ctxt src dest amount =\n transfer_n ~origin ctxt [(src, amount)] dest\n" ;
} ;
{ name = "Fees_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error += Cannot_pay_storage_fee (* `Temporary *)\n\ntype error += Negative_storage_input (* `Temporary *)\n\ntype error += Operation_quota_exceeded (* `Temporary *)\n\ntype error += Storage_limit_too_high (* `Permanent *)\n\n(** [record_global_constant_storage_space ctxt size] records\n paid storage space for registering a new global constant.\n Cost is <size> in bytes + 65 additional bytes for the key\n hash of the expression. Returns new context and the cost.\n*)\nval record_global_constant_storage_space :\n Raw_context.t -> Z.t -> Raw_context.t * Z.t\n\n(** [record_paid_storage_space ctxt contract] updates the amount of\n storage consumed by the [contract]. This total size is considered\n as accounted for as far as future payment is concerned.\n\n Returns a new context, the total space consumed by the [contract],\n and the additional (and unpaid) space consumed since the last call\n of this function on this [contract]. *)\nval record_paid_storage_space :\n Raw_context.t -> Contract_hash.t -> (Raw_context.t * Z.t * Z.t) tzresult Lwt.t\n\n(** [check_storage_limit ctxt ~storage_limit] raises the [Storage_limit_too_high]\n error iff [storage_limit] is negative or greater the constant\n [hard_storage_limit_per_operation]. *)\nval check_storage_limit : Raw_context.t -> storage_limit:Z.t -> unit tzresult\n\n(** [burn_storage_fees ctxt ~storage_limit ~payer consumed] takes funds from the\n [payer] to pay the cost of the [consumed] storage. This function has an\n optional parameter [~origin] that allows to set the origin of returned\n balance updates (by default the parameter is set to [Block_application]).\n Returns an updated context, an updated storage limit equal to\n [storage_limit - consumed], and the relevant balance updates.\n Raises the [Operation_quota_exceeded] error if [storage_limit < consumed].\n Raises the [Cannot_pay_storage_fee] error if the funds from the [payer] are\n not sufficient to pay the storage fees. *)\nval burn_storage_fees :\n ?origin:Receipt_repr.update_origin ->\n Raw_context.t ->\n storage_limit:Z.t ->\n payer:Token.source ->\n Z.t ->\n (Raw_context.t * Z.t * Receipt_repr.balance_updates) tzresult Lwt.t\n\n(** [burn_storage_increase_fees ctxt ~payer amount_in_bytes] takes funds from the\n [payer] to pay the cost of the [amount_in_bytes] storage. This function has an\n optional parameter [~origin] that allows to set the origin of returned\n balance updates (by default the parameter is set to [Block_application]).\n Returns an updated context and the relevant balance updates.\n Raises the [Negative_storage_input] error if the amount_in_bytes is null or negative.\n Raises the [Cannot_pay_storage_fee] error if the funds from the [payer] are\n not sufficient to pay the storage fees. *)\nval burn_storage_increase_fees :\n ?origin:Receipt_repr.update_origin ->\n Raw_context.t ->\n payer:Token.source ->\n Z.t ->\n (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t\n\n(** Calls [burn_storage_fees] with the parameter [consumed] mapped to the\n constant [origination_size]. *)\nval burn_origination_fees :\n ?origin:Receipt_repr.update_origin ->\n Raw_context.t ->\n storage_limit:Z.t ->\n payer:Token.source ->\n (Raw_context.t * Z.t * Receipt_repr.balance_updates) tzresult Lwt.t\n\n(** Calls [burn_storage_fees] with the parameter [consumed] mapped to the\n constant [tx_rollup_origination_size]. *)\nval burn_tx_rollup_origination_fees :\n ?origin:Receipt_repr.update_origin ->\n Raw_context.t ->\n storage_limit:Z.t ->\n payer:Token.source ->\n (Raw_context.t * Z.t * Receipt_repr.balance_updates) tzresult Lwt.t\n\n(** [burn_sc_rollup_origination_fees ~origin ctxt ~storage_limit ~payer consumed]\n burns the storage fees for smart contract rollup creation fees. *)\nval burn_sc_rollup_origination_fees :\n ?origin:Receipt_repr.update_origin ->\n Raw_context.t ->\n storage_limit:Z.t ->\n payer:Token.source ->\n Z.t ->\n (Raw_context.t * Z.t * Receipt_repr.balance_updates) tzresult Lwt.t\n\n(** [burn_zk_rollup_origination_fees ~origin ctxt ~storage_limit ~payer consumed]\n burns the storage fees for ZK rollup origination fees. *)\nval burn_zk_rollup_origination_fees :\n ?origin:Receipt_repr.update_origin ->\n Raw_context.t ->\n storage_limit:Z.t ->\n payer:Token.source ->\n Z.t ->\n (Raw_context.t * Z.t * Receipt_repr.balance_updates) tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error += Cannot_pay_storage_fee (* `Temporary *)\n\ntype error += Negative_storage_input (* `Temporary *)\n\ntype error += Operation_quota_exceeded (* `Temporary *)\n\ntype error += Storage_limit_too_high (* `Permanent *)\n\nlet () =\n let open Data_encoding in\n register_error_kind\n `Temporary\n ~id:\"contract.cannot_pay_storage_fee\"\n ~title:\"Cannot pay storage fee\"\n ~description:\"The storage fee is higher than the contract balance\"\n ~pp:(fun ppf () -> Format.fprintf ppf \"Cannot pay storage fee\")\n Data_encoding.empty\n (function Cannot_pay_storage_fee -> Some () | _ -> None)\n (fun () -> Cannot_pay_storage_fee) ;\n register_error_kind\n `Temporary\n ~id:\"contract.negative_storage_input\"\n ~title:\"Negative storage input\"\n ~description:\"The storage amount asked for an operation is null or negative\"\n ~pp:(fun ppf () -> Format.fprintf ppf \"Null or negative storage input\")\n Data_encoding.empty\n (function Negative_storage_input -> Some () | _ -> None)\n (fun () -> Negative_storage_input) ;\n register_error_kind\n `Temporary\n ~id:\"storage_exhausted.operation\"\n ~title:\"Storage quota exceeded for the operation\"\n ~description:\n \"A script or one of its callee wrote more bytes than the operation said \\\n it would\"\n Data_encoding.empty\n (function Operation_quota_exceeded -> Some () | _ -> None)\n (fun () -> Operation_quota_exceeded) ;\n register_error_kind\n `Permanent\n ~id:\"storage_limit_too_high\"\n ~title:\"Storage limit out of protocol hard bounds\"\n ~description:\"A transaction tried to exceed the hard limit on storage\"\n empty\n (function Storage_limit_too_high -> Some () | _ -> None)\n (fun () -> Storage_limit_too_high)\n\nlet record_global_constant_storage_space context size =\n (* Following the precedent of big_map, a key in the\n global table of constants costs 65 bytes (see\n [Lazy_storage_diff.Big_map.bytes_size_for_big_map_key])*)\n let cost_of_key = Z.of_int 65 in\n let to_be_paid = Z.add size cost_of_key in\n (context, to_be_paid)\n\nlet record_paid_storage_space ctxt contract_hash =\n let contract = Contract_repr.Originated contract_hash in\n (* Get the new size of the contract's storage. *)\n Contract_storage.used_storage_space ctxt contract >>=? fun new_storage_size ->\n Contract_storage.set_paid_storage_space_and_return_fees_to_pay\n ctxt\n contract\n new_storage_size\n >>=? fun (to_be_paid, c) -> return (c, new_storage_size, to_be_paid)\n\nlet source_must_exist c src =\n match src with\n | `Contract src -> Contract_storage.must_exist c src\n | _ -> return_unit\n\nlet burn_storage_fees ?(origin = Receipt_repr.Block_application) c\n ~storage_limit ~payer consumed =\n let remaining = Z.sub storage_limit consumed in\n if Compare.Z.(remaining < Z.zero) then tzfail Operation_quota_exceeded\n else\n let cost_per_byte = Constants_storage.cost_per_byte c in\n Tez_repr.(cost_per_byte *? Z.to_int64 consumed) >>?= fun to_burn ->\n (* Burning the fees... *)\n if Tez_repr.(to_burn = Tez_repr.zero) then\n (* If the payer was deleted by transferring all its balance, and no space\n was used, burning zero would fail *)\n return (c, remaining, [])\n else\n trace\n Cannot_pay_storage_fee\n ( source_must_exist c payer >>=? fun () ->\n Token.transfer ~origin c payer `Storage_fees to_burn\n >>=? fun (ctxt, balance_updates) ->\n return (ctxt, remaining, balance_updates) )\n\nlet burn_storage_increase_fees ?(origin = Receipt_repr.Block_application) c\n ~payer amount_in_bytes =\n if Compare.Z.(amount_in_bytes <= Z.zero) then tzfail Negative_storage_input\n else\n let cost_per_byte = Constants_storage.cost_per_byte c in\n Tez_repr.(cost_per_byte *? Z.to_int64 amount_in_bytes) >>?= fun to_burn ->\n (* Burning the fees... *)\n trace\n Cannot_pay_storage_fee\n ( source_must_exist c payer >>=? fun () ->\n Token.transfer ~origin c payer `Storage_fees to_burn )\n\nlet burn_origination_fees ?(origin = Receipt_repr.Block_application) c\n ~storage_limit ~payer =\n let origination_size = Constants_storage.origination_size c in\n burn_storage_fees ~origin c ~storage_limit ~payer (Z.of_int origination_size)\n\nlet burn_tx_rollup_origination_fees ?(origin = Receipt_repr.Block_application) c\n ~storage_limit ~payer =\n let tx_rollup_origination_size =\n Constants_storage.tx_rollup_origination_size c\n in\n burn_storage_fees\n ~origin\n c\n ~storage_limit\n ~payer\n (Z.of_int tx_rollup_origination_size)\n\nlet burn_sc_rollup_origination_fees ?(origin = Receipt_repr.Block_application) c\n ~storage_limit ~payer consumed =\n burn_storage_fees ~origin c ~storage_limit ~payer consumed\n\nlet burn_zk_rollup_origination_fees ?(origin = Receipt_repr.Block_application) c\n ~storage_limit ~payer consumed =\n burn_storage_fees ~origin c ~storage_limit ~payer consumed\n\nlet check_storage_limit c ~storage_limit =\n if\n Compare.Z.(\n storage_limit > (Raw_context.constants c).hard_storage_limit_per_operation)\n || Compare.Z.(storage_limit < Z.zero)\n then error Storage_limit_too_high\n else Result.return_unit\n" ;
} ;
{ name = "Delegate_consensus_key" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 G.B. Fefe, <gb.fefe@protonmail.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Management of a delegate's consensus key, the one used to sign\n blocks and consensus operations. It is responsible for maintaining\n the tables {!Storage.Consensus_keys},\n {!Storage.Contract.Consensus_key}, and\n {!Storage.Contract.Pending_consensus_keys}. *)\n\ntype error +=\n | Invalid_consensus_key_update_noop of Cycle_repr.t\n | Invalid_consensus_key_update_active\n | Invalid_consensus_key_update_tz4 of Bls.Public_key.t\n\n(** The public key of a consensus key and the associated delegate. *)\ntype pk = Raw_context.consensus_pk = {\n delegate : Signature.Public_key_hash.t;\n consensus_pk : Signature.Public_key.t;\n consensus_pkh : Signature.Public_key_hash.t;\n}\n\n(** The public key hash of a consensus key and the associated delegate. *)\ntype t = {\n delegate : Signature.Public_key_hash.t;\n consensus_pkh : Signature.Public_key_hash.t;\n}\n\nval zero : t\n\nval pp : Format.formatter -> t -> unit\n\nval pkh : pk -> t\n\n(** [check_not_tz4 pk] checks that [pk] is not a BLS address. *)\nval check_not_tz4 : Signature.public_key -> unit tzresult\n\n(** Initialize the consensus key when registering a delegate. *)\nval init :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Signature.Public_key.t ->\n Raw_context.t tzresult Lwt.t\n\n(** Returns the active consensus key for the current cycle. *)\nval active_pubkey :\n Raw_context.t -> Signature.Public_key_hash.t -> pk tzresult Lwt.t\n\n(** Returns the active consensus key for the current cycle. *)\nval active_key :\n Raw_context.t -> Signature.Public_key_hash.t -> t tzresult Lwt.t\n\n(** Returns the active consensus key for the given cycle. *)\nval active_pubkey_for_cycle :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Cycle_repr.t ->\n pk tzresult Lwt.t\n\n(** Returns the list of pending consensus-key updates in upcoming cycles. *)\nval pending_updates :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n (Cycle_repr.t * Signature.Public_key_hash.t) list tzresult Lwt.t\n\n(** Register a consensus-key update. *)\nval register_update :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Signature.Public_key.t ->\n Raw_context.t tzresult Lwt.t\n\n(** Activate consensus keys at the beginning of cycle [new_cycle].\n This function iterates on all registered delegates. *)\nval activate :\n Raw_context.t -> new_cycle:Cycle_repr.t -> Raw_context.t tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 G.B. Fefe, <gb.fefe@protonmail.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error +=\n | Invalid_consensus_key_update_noop of Cycle_repr.t\n | Invalid_consensus_key_update_active\n | Invalid_consensus_key_update_tz4 of Bls.Public_key.t\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"delegate.consensus_key.invalid_noop\"\n ~title:\"Invalid key for consensus key update\"\n ~description:\"Tried to update the consensus key with the active key\"\n ~pp:(fun ppf cycle ->\n Format.fprintf\n ppf\n \"Invalid key while updating a consensus key (already active since %a).\"\n Cycle_repr.pp\n cycle)\n Data_encoding.(obj1 (req \"cycle\" Cycle_repr.encoding))\n (function Invalid_consensus_key_update_noop c -> Some c | _ -> None)\n (fun c -> Invalid_consensus_key_update_noop c) ;\n register_error_kind\n `Permanent\n ~id:\"delegate.consensus_key.active\"\n ~title:\"Active consensus key\"\n ~description:\n \"The delegate consensus key is already used by another delegate\"\n ~pp:(fun ppf () ->\n Format.fprintf\n ppf\n \"The delegate consensus key is already used by another delegate\")\n Data_encoding.empty\n (function Invalid_consensus_key_update_active -> Some () | _ -> None)\n (fun () -> Invalid_consensus_key_update_active) ;\n register_error_kind\n `Permanent\n ~id:\"delegate.consensus_key.tz4\"\n ~title:\"Consensus key cannot be a tz4\"\n ~description:\"Consensus key cannot be a tz4 (BLS public key).\"\n ~pp:(fun ppf pk ->\n Format.fprintf\n ppf\n \"The consensus key %a is forbidden as it is a BLS public key.\"\n Bls.Public_key_hash.pp\n (Bls.Public_key.hash pk))\n Data_encoding.(obj1 (req \"delegate_pk\" Bls.Public_key.encoding))\n (function Invalid_consensus_key_update_tz4 pk -> Some pk | _ -> None)\n (fun pk -> Invalid_consensus_key_update_tz4 pk)\n\ntype pk = Raw_context.consensus_pk = {\n delegate : Signature.Public_key_hash.t;\n consensus_pk : Signature.Public_key.t;\n consensus_pkh : Signature.Public_key_hash.t;\n}\n\ntype t = {\n delegate : Signature.Public_key_hash.t;\n consensus_pkh : Signature.Public_key_hash.t;\n}\n\nlet pkh {delegate; consensus_pkh; consensus_pk = _} = {delegate; consensus_pkh}\n\nlet zero =\n {\n consensus_pkh = Signature.Public_key_hash.zero;\n delegate = Signature.Public_key_hash.zero;\n }\n\nlet pp ppf {delegate; consensus_pkh} =\n Format.fprintf ppf \"@[<v 2>%a\" Signature.Public_key_hash.pp delegate ;\n if not (Signature.Public_key_hash.equal delegate consensus_pkh) then\n Format.fprintf\n ppf\n \"@,Active key: %a\"\n Signature.Public_key_hash.pp\n consensus_pkh ;\n Format.fprintf ppf \"@]\"\n\n(* Invariant:\n No two delegates use the same active consensus key at a given time.\n\n To ensure that, {!Storage.Consensus_keys} contains keys that will be active\n at cycle `current + preserved_cycles + 1`.\n*)\n\nlet check_unused ctxt pkh =\n let open Lwt_result_syntax in\n let*! is_active = Storage.Consensus_keys.mem ctxt pkh in\n fail_when is_active Invalid_consensus_key_update_active\n\nlet check_not_tz4 : Signature.Public_key.t -> unit tzresult = function\n | Bls pk -> error (Invalid_consensus_key_update_tz4 pk)\n | Ed25519 _ | Secp256k1 _ | P256 _ -> Ok ()\n\nlet set_unused = Storage.Consensus_keys.remove\n\nlet set_used = Storage.Consensus_keys.add\n\nlet init ctxt delegate pk =\n let open Lwt_result_syntax in\n let*? () = check_not_tz4 pk in\n let pkh = Signature.Public_key.hash pk in\n let* () = check_unused ctxt pkh in\n let*! ctxt = set_used ctxt pkh in\n Storage.Contract.Consensus_key.init ctxt (Contract_repr.Implicit delegate) pk\n\nlet active_pubkey ctxt delegate =\n let open Lwt_result_syntax in\n let* pk =\n Storage.Contract.Consensus_key.get ctxt (Contract_repr.Implicit delegate)\n in\n let pkh = Signature.Public_key.hash pk in\n return {consensus_pk = pk; consensus_pkh = pkh; delegate}\n\nlet active_key ctxt delegate =\n let open Lwt_result_syntax in\n let* pk = active_pubkey ctxt delegate in\n return (pkh pk)\n\nlet raw_pending_updates ctxt delegate =\n let open Lwt_result_syntax in\n let*! pendings =\n Storage.Contract.Pending_consensus_keys.bindings\n (ctxt, Contract_repr.Implicit delegate)\n in\n return pendings\n\nlet pending_updates ctxt delegate =\n let open Lwt_result_syntax in\n let* updates = raw_pending_updates ctxt delegate in\n let updates =\n List.sort (fun (c1, _) (c2, _) -> Cycle_repr.compare c1 c2) updates\n in\n return (List.map (fun (c, pk) -> (c, Signature.Public_key.hash pk)) updates)\n\nlet raw_active_pubkey_for_cycle ctxt delegate cycle =\n let open Lwt_result_syntax in\n let* pendings = raw_pending_updates ctxt delegate in\n let* active = active_pubkey ctxt delegate in\n let current_level = Raw_context.current_level ctxt in\n let active_for_cycle =\n List.fold_left\n (fun (c1, active) (c2, pk) ->\n if Cycle_repr.(c1 < c2 && c2 <= cycle) then (c2, pk) else (c1, active))\n (current_level.cycle, active.consensus_pk)\n pendings\n in\n return active_for_cycle\n\nlet active_pubkey_for_cycle ctxt delegate cycle =\n let open Lwt_result_syntax in\n let* _, consensus_pk = raw_active_pubkey_for_cycle ctxt delegate cycle in\n return\n {\n consensus_pk;\n consensus_pkh = Signature.Public_key.hash consensus_pk;\n delegate;\n }\n\nlet register_update ctxt delegate pk =\n let open Lwt_result_syntax in\n let update_cycle =\n let current_level = Raw_context.current_level ctxt in\n let preserved_cycles = Constants_storage.preserved_cycles ctxt in\n Cycle_repr.add current_level.cycle (preserved_cycles + 1)\n in\n let* () =\n let* first_active_cycle, active_pubkey =\n raw_active_pubkey_for_cycle ctxt delegate update_cycle\n in\n fail_when\n Signature.Public_key.(pk = active_pubkey)\n (Invalid_consensus_key_update_noop first_active_cycle)\n in\n let*? () = check_not_tz4 pk in\n let pkh = Signature.Public_key.hash pk in\n let* () = check_unused ctxt pkh in\n let*! ctxt = set_used ctxt pkh in\n let* {consensus_pkh = old_pkh; _} =\n active_pubkey_for_cycle ctxt delegate update_cycle\n in\n let*! ctxt = set_unused ctxt old_pkh in\n let*! ctxt =\n Storage.Contract.Pending_consensus_keys.add\n (ctxt, Contract_repr.Implicit delegate)\n update_cycle\n pk\n in\n return ctxt\n\nlet activate ctxt ~new_cycle =\n let open Lwt_result_syntax in\n Storage.Delegates.fold\n ctxt\n ~order:`Undefined\n ~init:(ok ctxt)\n ~f:(fun delegate ctxt ->\n let*? ctxt = ctxt in\n let delegate = Contract_repr.Implicit delegate in\n let* update =\n Storage.Contract.Pending_consensus_keys.find (ctxt, delegate) new_cycle\n in\n match update with\n | None -> return ctxt\n | Some pk ->\n let*! ctxt = Storage.Contract.Consensus_key.add ctxt delegate pk in\n let*! ctxt =\n Storage.Contract.Pending_consensus_keys.remove\n (ctxt, delegate)\n new_cycle\n in\n return ctxt)\n" ;
} ;
{ name = "Delegate_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 G.B. Fefe, <gb.fefe@protonmail.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module groups everything related to delegate registration.\n For the invariants maintained, see the submodule {!Contract}.\n\n It also groups \"trivial\" getters/setters related to delegates.\n\n It is responsible for maintaining the following tables:\n - {!Storage.Contract.Frozen_deposits_limit}\n - {!Storage.Delegates}\n*)\n\ntype error +=\n | (* `Permanent *) Unregistered_delegate of Signature.Public_key_hash.t\n\n(** This module ensures the following invariants:\n - registered delegates (i.e. those that appear in {!Storage.Delegates}) are\n self-delegated, that is a delegate's implicit account delegates to itself\n (i.e. {!Contract_delegate_storage.find} [delegate] returns [delegate]),\n - registered delegates have their public keys revealed,\n - registered delegates cannot change their delegation,\n - stake is properly moved when changing delegation.\n*)\nmodule Contract : sig\n type error +=\n | (* `Temporary *) Active_delegate\n | (* `Permanent *) Empty_delegate_account of Signature.Public_key_hash.t\n | (* `Permanent *) No_deletion of Signature.Public_key_hash.t\n | (* `Temporary *) Current_delegate\n\n (** [init ctxt contract delegate] registers a delegate when\n creating a contract.\n\n This functions assumes that [contract] is allocated.\n\n This function returns the {!Unregistered_delegate} error\n if [contract] already has a delegate or\n if [delegate] is not a registered delegate. *)\n val init :\n Raw_context.t ->\n Contract_repr.t ->\n Signature.Public_key_hash.t ->\n Raw_context.t tzresult Lwt.t\n\n (** [set ctxt contract delegate_opt] allows to set the\n delegate of a contract to [delegate] when [delegate_opt = Some delegate]\n or to unset the delegate when [delegate_opt = None].\n When [delegate_opt = Some contract] (aka self-delegation),\n the function also registers the contract as a delegate and\n sets the delegate as {{!module:Delegate_activation_storage}active}.\n\n It returns the {!Unregistered_delegate} error when self-delegating and when the public key is not yet revealed.\n It returns the {!Empty_delegate_account} error when self-delegating and the implicit account is not {{!Contract_storage.allocated}allocated}.\n It returns the {!Active_delegate} error when self-delegating and the delegate is already active.\n It returns the {!Unregistered_delegate} error when trying to set the delegate to an unregistered delegate.\n It returns the {!Current_delegate} error when contract is already delegated to the same delegate.\n It returns the {!No_deletion} error when trying to unset or change the delegate of a registered delegate. *)\n val set :\n Raw_context.t ->\n Contract_repr.t ->\n Signature.Public_key_hash.t option ->\n Raw_context.t tzresult Lwt.t\nend\n\n(** Has a delegate been registered in the delegate table? *)\nval registered : Raw_context.t -> Signature.Public_key_hash.t -> bool Lwt.t\n\n(** Iterate on all registered delegates. *)\nval fold :\n Raw_context.t ->\n order:[`Sorted | `Undefined] ->\n init:'a ->\n f:(Signature.Public_key_hash.t -> 'a -> 'a Lwt.t) ->\n 'a Lwt.t\n\n(** List all registered delegates. *)\nval list : Raw_context.t -> Signature.Public_key_hash.t list Lwt.t\n\nval frozen_deposits_limit :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Tez_repr.t option tzresult Lwt.t\n\nval set_frozen_deposits_limit :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Tez_repr.t option ->\n Raw_context.t Lwt.t\n\n(** Returns a delegate's frozen deposits, both the current amount and\n the initial freezed amount.\n\n A delegate's frozen balance is only composed of frozen deposits;\n rewards and fees are not frozen, but simply credited at the right\n moment. *)\nval frozen_deposits :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Storage.deposits tzresult Lwt.t\n\nval spendable_balance :\n Raw_context.t -> Signature.public_key_hash -> Tez_repr.tez tzresult Lwt.t\n\nval staking_balance :\n Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t\n\n(** Returns the full 'balance' of the implicit contract associated to\n a given key, i.e. the sum of the spendable balance (given by [balance] or\n [Contract_storage.get_balance]) and of the frozen balance. The frozen\n balance is composed of all frozen bonds associated to the contract (given by\n [Contract_storage.get_frozen_bonds]) and of the frozen deposits (given by\n [frozen_deposits]).\n\n Only use this function for RPCs: this is expensive. *)\nval full_balance :\n Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t\n\n(** Only use this function for RPCs: this is expensive. *)\nval delegated_balance :\n Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t\n\nval drain :\n Raw_context.t ->\n delegate:Signature.Public_key_hash.t ->\n destination:Signature.Public_key_hash.t ->\n (Raw_context.t * bool * Tez_repr.t * Receipt_repr.balance_updates) tzresult\n Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 G.B. Fefe, <gb.fefe@protonmail.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error +=\n | (* `Permanent *) Unregistered_delegate of Signature.Public_key_hash.t\n\nlet () =\n (* Unregistered delegate *)\n register_error_kind\n `Permanent\n ~id:\"contract.manager.unregistered_delegate\"\n ~title:\"Unregistered delegate\"\n ~description:\"A contract cannot be delegated to an unregistered delegate\"\n ~pp:(fun ppf k ->\n Format.fprintf\n ppf\n \"The provided public key (with hash %a) is not registered as valid \\\n delegate key.\"\n Signature.Public_key_hash.pp\n k)\n Data_encoding.(obj1 (req \"hash\" Signature.Public_key_hash.encoding))\n (function Unregistered_delegate k -> Some k | _ -> None)\n (fun k -> Unregistered_delegate k)\n\nlet registered = Storage.Delegates.mem\n\nmodule Contract = struct\n let init ctxt contract delegate =\n Contract_manager_storage.is_manager_key_revealed ctxt delegate\n >>=? fun known_delegate ->\n error_unless known_delegate (Unregistered_delegate delegate) >>?= fun () ->\n registered ctxt delegate >>= fun is_registered ->\n error_unless is_registered (Unregistered_delegate delegate) >>?= fun () ->\n Contract_delegate_storage.init ctxt contract delegate >>=? fun ctxt ->\n Contract_storage.get_balance_and_frozen_bonds ctxt contract\n >>=? fun balance_and_frozen_bonds ->\n Stake_storage.add_stake ctxt delegate balance_and_frozen_bonds\n\n type error +=\n | (* `Temporary *) Active_delegate\n | (* `Permanent *) Empty_delegate_account of Signature.Public_key_hash.t\n\n let () =\n register_error_kind\n `Temporary\n ~id:\"delegate.already_active\"\n ~title:\"Delegate already active\"\n ~description:\"Useless delegate reactivation\"\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"The delegate is still active, no need to refresh it\")\n Data_encoding.empty\n (function Active_delegate -> Some () | _ -> None)\n (fun () -> Active_delegate) ;\n register_error_kind\n `Permanent\n ~id:\"delegate.empty_delegate_account\"\n ~title:\"Empty delegate account\"\n ~description:\n \"Cannot register a delegate when its implicit account is empty\"\n ~pp:(fun ppf delegate ->\n Format.fprintf\n ppf\n \"Delegate registration is forbidden when the delegate\\n\\\n \\ implicit account is empty (%a)\"\n Signature.Public_key_hash.pp\n delegate)\n Data_encoding.(obj1 (req \"delegate\" Signature.Public_key_hash.encoding))\n (function Empty_delegate_account c -> Some c | _ -> None)\n (fun c -> Empty_delegate_account c)\n\n let set_self_delegate c delegate =\n let open Lwt_result_syntax in\n let*! is_registered = registered c delegate in\n if is_registered then\n let* () =\n let* is_inactive = Delegate_activation_storage.is_inactive c delegate in\n fail_unless is_inactive Active_delegate\n in\n Stake_storage.set_active c delegate\n else\n let contract = Contract_repr.Implicit delegate in\n let* pk =\n Contract_manager_storage.get_manager_key\n c\n ~error:(Unregistered_delegate delegate)\n delegate\n in\n let* () =\n let*! is_allocated = Contract_storage.allocated c contract in\n fail_unless is_allocated (Empty_delegate_account delegate)\n in\n let* balance_and_frozen_bonds =\n Contract_storage.get_balance_and_frozen_bonds c contract\n in\n let* c =\n Stake_storage.remove_contract_stake c contract balance_and_frozen_bonds\n in\n let* c = Contract_delegate_storage.set c contract delegate in\n let* c = Stake_storage.add_stake c delegate balance_and_frozen_bonds in\n let*! c = Storage.Delegates.add c delegate in\n let* c = Delegate_consensus_key.init c delegate pk in\n let* c = Stake_storage.set_active c delegate in\n return c\n\n type error +=\n | (* `Permanent *) No_deletion of Signature.Public_key_hash.t\n | (* `Temporary *) Current_delegate\n\n let () =\n register_error_kind\n `Permanent\n ~id:\"delegate.no_deletion\"\n ~title:\"Forbidden delegate deletion\"\n ~description:\"Tried to unregister a delegate\"\n ~pp:(fun ppf delegate ->\n Format.fprintf\n ppf\n \"Delegate deletion is forbidden (%a)\"\n Signature.Public_key_hash.pp\n delegate)\n Data_encoding.(obj1 (req \"delegate\" Signature.Public_key_hash.encoding))\n (function No_deletion c -> Some c | _ -> None)\n (fun c -> No_deletion c) ;\n register_error_kind\n `Temporary\n ~id:\"delegate.unchanged\"\n ~title:\"Unchanged delegated\"\n ~description:\"Contract already delegated to the given delegate\"\n ~pp:(fun ppf () ->\n Format.fprintf\n ppf\n \"The contract is already delegated to the same delegate\")\n Data_encoding.empty\n (function Current_delegate -> Some () | _ -> None)\n (fun () -> Current_delegate)\n\n let set_delegate c contract delegate =\n let open Lwt_result_syntax in\n let* () =\n match contract with\n | Contract_repr.Originated _ -> return_unit\n | Implicit pkh ->\n let*! is_registered = registered c pkh in\n fail_when is_registered (No_deletion pkh)\n in\n let* () =\n let* current_delegate = Contract_delegate_storage.find c contract in\n match (delegate, current_delegate) with\n | None, None ->\n (* we don't fail in this case in order not to risk breaking\n existing smart contracts. *)\n return_unit\n | Some delegate, Some current_delegate\n when Signature.Public_key_hash.equal delegate current_delegate ->\n tzfail Current_delegate\n | _ -> return_unit\n in\n let* balance_and_frozen_bonds =\n Contract_storage.get_balance_and_frozen_bonds c contract\n in\n let* c =\n Stake_storage.remove_contract_stake c contract balance_and_frozen_bonds\n in\n match delegate with\n | None ->\n let* c = Contract_delegate_storage.delete c contract in\n return c\n | Some delegate ->\n let* () =\n let*! is_delegate_registered = registered c delegate in\n fail_when\n (not is_delegate_registered)\n (Unregistered_delegate delegate)\n in\n let* c = Contract_delegate_storage.set c contract delegate in\n let* c = Stake_storage.add_stake c delegate balance_and_frozen_bonds in\n return c\n\n let set c contract delegate =\n match (delegate, contract) with\n | Some delegate, Contract_repr.Implicit source\n when Signature.Public_key_hash.equal source delegate ->\n set_self_delegate c delegate\n | _ -> set_delegate c contract delegate\nend\n\nlet fold = Storage.Delegates.fold\n\nlet list = Storage.Delegates.elements\n\nlet frozen_deposits_limit ctxt delegate =\n Storage.Contract.Frozen_deposits_limit.find\n ctxt\n (Contract_repr.Implicit delegate)\n\nlet set_frozen_deposits_limit ctxt delegate limit =\n Storage.Contract.Frozen_deposits_limit.add_or_remove\n ctxt\n (Contract_repr.Implicit delegate)\n limit\n\nlet frozen_deposits ctxt delegate =\n Frozen_deposits_storage.get ctxt (Contract_repr.Implicit delegate)\n\nlet spendable_balance ctxt delegate =\n let contract = Contract_repr.Implicit delegate in\n Storage.Contract.Spendable_balance.get ctxt contract\n\nlet staking_balance ctxt delegate =\n registered ctxt delegate >>= fun is_registered ->\n if is_registered then Stake_storage.get_staking_balance ctxt delegate\n else return Tez_repr.zero\n\nlet full_balance ctxt delegate =\n frozen_deposits ctxt delegate >>=? fun frozen_deposits ->\n let delegate_contract = Contract_repr.Implicit delegate in\n Contract_storage.get_balance_and_frozen_bonds ctxt delegate_contract\n >>=? fun balance_and_frozen_bonds ->\n Lwt.return\n Tez_repr.(frozen_deposits.current_amount +? balance_and_frozen_bonds)\n\nlet delegated_balance ctxt delegate =\n staking_balance ctxt delegate >>=? fun staking_balance ->\n full_balance ctxt delegate >>=? fun self_staking_balance ->\n Lwt.return Tez_repr.(staking_balance -? self_staking_balance)\n\nlet drain ctxt ~delegate ~destination =\n let open Lwt_result_syntax in\n let destination_contract = Contract_repr.Implicit destination in\n let*! is_destination_allocated =\n Contract_storage.allocated ctxt destination_contract\n in\n let delegate_contract = Contract_repr.Implicit delegate in\n let* ctxt, _, balance_updates1 =\n if not is_destination_allocated then\n Fees_storage.burn_origination_fees\n ctxt\n ~storage_limit:(Z.of_int (Constants_storage.origination_size ctxt))\n ~payer:(`Contract delegate_contract)\n else return (ctxt, Z.zero, [])\n in\n let* manager_balance = spendable_balance ctxt delegate in\n let*? one_percent = Tez_repr.(manager_balance /? 100L) in\n let fees = Tez_repr.(max one one_percent) in\n let*? transferred = Tez_repr.(manager_balance -? fees) in\n let* ctxt, balance_updates2 =\n Token.transfer\n ctxt\n (`Contract delegate_contract)\n (`Contract destination_contract)\n transferred\n in\n return\n ( ctxt,\n not is_destination_allocated,\n fees,\n balance_updates1 @ balance_updates2 )\n" ;
} ;
{ name = "Delegate_sampler" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 G.B. Fefe, <gb.fefe@protonmail.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module draws random values for a cycle based on the {!Seed_repr.seed}\n associated that cycle. These random values are:\n - delegates associated with slots\n - snapshot indexes.\n The selection of delegates is done by {i sampling} from a particular\n distribution of the stake among the active delegates.\n\n This module is responsible for maintaining the table\n {!Storage.Delegate_sampler_state}. *)\n\n(** Participation slots potentially associated to accounts. The\n accounts that didn't place a deposit will be excluded from this\n list. This function should only be used to compute the deposits to\n freeze or initialize the protocol while stitching. RPCs can use this\n function to predict an approximation of long term future slot\n allocations. It shouldn't be used in the baker. *)\nval slot_owner :\n Raw_context.t ->\n Level_repr.t ->\n Slot_repr.t ->\n (Raw_context.t * Delegate_consensus_key.pk) tzresult Lwt.t\n\nval baking_rights_owner :\n Raw_context.t ->\n Level_repr.t ->\n round:Round_repr.round ->\n (Raw_context.t * Slot_repr.t * Delegate_consensus_key.pk) tzresult Lwt.t\n\n(** [compute_snapshot_index ctxt cycle max_snapshot_index] Returns the index of\n the selected snapshot for the [cycle] passed as argument, and for the max\n index of snapshots taken so far, [max_snapshot_index] (see\n [Stake_storage.max_snapshot_index]. *)\nval compute_snapshot_index :\n Raw_context.t -> Cycle_repr.t -> max_snapshot_index:int -> int tzresult Lwt.t\n\nval select_new_distribution_at_cycle_end :\n Raw_context.t -> new_cycle:Cycle_repr.t -> Raw_context.t tzresult Lwt.t\n\nval clear_outdated_sampling_data :\n Raw_context.t -> new_cycle:Cycle_repr.t -> Raw_context.t tzresult Lwt.t\n\nval select_distribution_for_cycle :\n Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 G.B. Fefe, <gb.fefe@protonmail.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule Delegate_sampler_state = struct\n module Cache_client = struct\n type cached_value = Delegate_consensus_key.pk Sampler.t\n\n let namespace = Cache_repr.create_namespace \"sampler_state\"\n\n let cache_index = 2\n\n let value_of_identifier ctxt identifier =\n let cycle = Cycle_repr.of_string_exn identifier in\n Storage.Delegate_sampler_state.get ctxt cycle\n end\n\n module Cache = (val Cache_repr.register_exn (module Cache_client))\n\n let identifier_of_cycle cycle = Format.asprintf \"%a\" Cycle_repr.pp cycle\n\n let init ctxt cycle sampler_state =\n let id = identifier_of_cycle cycle in\n Storage.Delegate_sampler_state.init ctxt cycle sampler_state\n >>=? fun ctxt ->\n let size = 1 (* that's symbolic: 1 cycle = 1 entry *) in\n Cache.update ctxt id (Some (sampler_state, size)) >>?= fun ctxt ->\n return ctxt\n\n let get ctxt cycle =\n let id = identifier_of_cycle cycle in\n Cache.find ctxt id >>=? function\n | None -> Storage.Delegate_sampler_state.get ctxt cycle\n | Some v -> return v\n\n let remove_existing ctxt cycle =\n let id = identifier_of_cycle cycle in\n Cache.update ctxt id None >>?= fun ctxt ->\n Storage.Delegate_sampler_state.remove_existing ctxt cycle\nend\n\nmodule Random = struct\n (* [init_random_state] initialize a random sequence drawing state\n that's unique for a given (seed, level, index) triple. Elements\n from this sequence are drawn using [take_int64], updating the\n state for the next draw. The initial state is the Blake2b hash of\n the three randomness sources, and an offset set to zero\n (indicating that zero bits of randomness have been\n consumed). When drawing random elements, bits are extracted from\n the state until exhaustion (256 bits), at which point the state\n is rehashed and the offset reset to 0. *)\n\n let init_random_state seed level index =\n ( Raw_hashes.blake2b\n (Data_encoding.Binary.to_bytes_exn\n Data_encoding.(tup3 Seed_repr.seed_encoding int32 int32)\n (seed, level.Level_repr.cycle_position, Int32.of_int index)),\n 0 )\n\n let take_int64 bound state =\n let drop_if_over =\n (* This function draws random values in [0-(bound-1)] by drawing\n in [0-(2^63-1)] (64-bit) and computing the value modulo\n [bound]. For the application of [mod bound] to preserve\n uniformity, the input space must be of the form\n [0-(n*bound-1)]. We enforce this by rejecting 64-bit samples\n above this limit (in which case, we draw a new 64-sample from\n the sequence and try again). *)\n Int64.sub Int64.max_int (Int64.rem Int64.max_int bound)\n in\n let rec loop (bytes, n) =\n let consumed_bytes = 8 in\n let state_size = Bytes.length bytes in\n if Compare.Int.(n > state_size - consumed_bytes) then\n loop (Raw_hashes.blake2b bytes, 0)\n else\n let r = TzEndian.get_int64 bytes n in\n (* The absolute value of min_int is min_int. Also, every\n positive integer is represented twice (positive and negative),\n but zero is only represented once. We fix both problems at\n once. *)\n let r = if Compare.Int64.(r = Int64.min_int) then 0L else Int64.abs r in\n if Compare.Int64.(r >= drop_if_over) then\n loop (bytes, n + consumed_bytes)\n else\n let v = Int64.rem r bound in\n (v, (bytes, n + consumed_bytes))\n in\n loop state\n\n (** [sampler_for_cycle ctxt cycle] reads the sampler for [cycle] from\n [ctxt] if it has been previously inited. Otherwise it initializes\n the sampler and caches it in [ctxt] with\n [Raw_context.set_sampler_for_cycle]. *)\n let sampler_for_cycle ctxt cycle =\n let read ctxt =\n Seed_storage.for_cycle ctxt cycle >>=? fun seed ->\n Delegate_sampler_state.get ctxt cycle >>=? fun state ->\n return (seed, state)\n in\n Raw_context.sampler_for_cycle ~read ctxt cycle\n\n let owner c (level : Level_repr.t) offset =\n let cycle = level.Level_repr.cycle in\n sampler_for_cycle c cycle >>=? fun (c, seed, state) ->\n let sample ~int_bound ~mass_bound =\n let state = init_random_state seed level offset in\n let i, state = take_int64 (Int64.of_int int_bound) state in\n let elt, _ = take_int64 mass_bound state in\n (Int64.to_int i, elt)\n in\n let pk = Sampler.sample state sample in\n return (c, pk)\nend\n\nlet slot_owner c level slot = Random.owner c level (Slot_repr.to_int slot)\n\nlet baking_rights_owner c (level : Level_repr.t) ~round =\n Round_repr.to_int round >>?= fun round ->\n let consensus_committee_size = Constants_storage.consensus_committee_size c in\n Slot_repr.of_int (round mod consensus_committee_size) >>?= fun slot ->\n slot_owner c level slot >>=? fun (ctxt, pk) -> return (ctxt, slot, pk)\n\nlet get_stakes_for_selected_index ctxt index =\n Stake_storage.fold_snapshot\n ctxt\n ~index\n ~f:(fun (delegate, staking_balance) (acc, total_stake) ->\n let delegate_contract = Contract_repr.Implicit delegate in\n let open Tez_repr in\n let open Lwt_result_syntax in\n let* frozen_deposits_limit =\n Delegate_storage.frozen_deposits_limit ctxt delegate\n in\n let* balance_and_frozen_bonds =\n Contract_storage.get_balance_and_frozen_bonds ctxt delegate_contract\n in\n let* frozen_deposits =\n Frozen_deposits_storage.get ctxt delegate_contract\n in\n let*? total_balance =\n balance_and_frozen_bonds +? frozen_deposits.current_amount\n in\n let* stake_for_cycle =\n let frozen_deposits_percentage =\n Int64.of_int @@ Constants_storage.frozen_deposits_percentage ctxt\n in\n let max_mutez = of_mutez_exn Int64.max_int in\n let frozen_deposits_limit =\n match frozen_deposits_limit with Some fdp -> fdp | None -> max_mutez\n in\n let aux = min total_balance frozen_deposits_limit in\n let*? overflow_bound = max_mutez /? 100L in\n if aux <= overflow_bound then\n let*? aux = aux *? 100L in\n let*? v = aux /? frozen_deposits_percentage in\n return (min v staking_balance)\n else\n let*? sbal = staking_balance /? 100L in\n let*? a = aux /? frozen_deposits_percentage in\n if sbal <= a then return staking_balance\n else\n let*? r = max_mutez /? frozen_deposits_percentage in\n return r\n in\n let*? total_stake = Tez_repr.(total_stake +? stake_for_cycle) in\n return ((delegate, stake_for_cycle) :: acc, total_stake))\n ~init:([], Tez_repr.zero)\n\nlet compute_snapshot_index_for_seed ~max_snapshot_index seed =\n let rd = Seed_repr.initialize_new seed [Bytes.of_string \"stake_snapshot\"] in\n let seq = Seed_repr.sequence rd 0l in\n Seed_repr.take_int32 seq (Int32.of_int max_snapshot_index)\n |> fst |> Int32.to_int |> return\n\nlet compute_snapshot_index ctxt cycle ~max_snapshot_index =\n Seed_storage.for_cycle ctxt cycle >>=? fun seed ->\n compute_snapshot_index_for_seed ~max_snapshot_index seed\n\nlet select_distribution_for_cycle ctxt cycle =\n Stake_storage.max_snapshot_index ctxt >>=? fun max_snapshot_index ->\n Seed_storage.raw_for_cycle ctxt cycle >>=? fun seed ->\n compute_snapshot_index_for_seed ~max_snapshot_index seed\n >>=? fun selected_index ->\n get_stakes_for_selected_index ctxt selected_index\n >>=? fun (stakes, total_stake) ->\n Stake_storage.set_selected_distribution_for_cycle\n ctxt\n cycle\n stakes\n total_stake\n >>=? fun ctxt ->\n List.fold_left_es\n (fun acc (pkh, stake) ->\n Delegate_consensus_key.active_pubkey_for_cycle ctxt pkh cycle\n >|=? fun pk -> (pk, Tez_repr.to_mutez stake) :: acc)\n []\n stakes\n >>=? fun stakes_pk ->\n let state = Sampler.create stakes_pk in\n Delegate_sampler_state.init ctxt cycle state >>=? fun ctxt ->\n (* pre-allocate the sampler *)\n Lwt.return (Raw_context.init_sampler_for_cycle ctxt cycle seed state)\n\nlet select_new_distribution_at_cycle_end ctxt ~new_cycle =\n let preserved = Constants_storage.preserved_cycles ctxt in\n let for_cycle = Cycle_repr.add new_cycle preserved in\n select_distribution_for_cycle ctxt for_cycle\n\nlet clear_outdated_sampling_data ctxt ~new_cycle =\n let max_slashing_period = Constants_storage.max_slashing_period ctxt in\n match Cycle_repr.sub new_cycle max_slashing_period with\n | None -> return ctxt\n | Some outdated_cycle ->\n Delegate_sampler_state.remove_existing ctxt outdated_cycle\n >>=? fun ctxt -> Seed_storage.remove_for_cycle ctxt outdated_cycle\n" ;
} ;
{ name = "Delegate_missed_endorsements_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 G.B. Fefe, <gb.fefe@protonmail.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This modules deals with delegates' participation in consensus.\n\n This module is responsible for maintaining the\n {!Storage.Contract.Missed_endorsements} table. *)\n\nval expected_slots_for_given_active_stake :\n Raw_context.t ->\n total_active_stake:Tez_repr.t ->\n active_stake:Tez_repr.t ->\n int\n\ntype level_participation = Participated | Didn't_participate\n\n(** Record the participation of a delegate as a validator. *)\nval record_endorsing_participation :\n Raw_context.t ->\n delegate:Signature.Public_key_hash.t ->\n participation:level_participation ->\n endorsing_power:int ->\n Raw_context.t tzresult Lwt.t\n\n(** Sets the payload and block producer as active. Pays the baking\n reward and the fees to the payload producer and the reward bonus to\n the payload producer (if the reward_bonus is not None).*)\nval record_baking_activity_and_pay_rewards_and_fees :\n Raw_context.t ->\n payload_producer:Signature.Public_key_hash.t ->\n block_producer:Signature.Public_key_hash.t ->\n baking_reward:Tez_repr.t ->\n reward_bonus:Tez_repr.t option ->\n (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t\n\n(** Check that a delegate participated enough in the last cycle\n (returns [true] if it did), and then reset the participation for\n preparing the next cycle. *)\nval check_and_reset_delegate_participation :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n (Raw_context.t * bool) tzresult Lwt.t\n\n(** Participation information. We denote by:\n - \"static\" information that does not change during the cycle\n - \"dynamic\" information that may change during the cycle *)\ntype participation_info = {\n expected_cycle_activity : int;\n (** The total expected slots to be endorsed in the cycle. (static) *)\n minimal_cycle_activity : int;\n (** The minimal endorsing slots in the cycle to get endorsing\n rewards. (static) *)\n missed_slots : int;\n (** The number of missed endorsing slots in the cycle. (dynamic) *)\n missed_levels : int;\n (** The number of missed endorsing levels in the cycle. (dynamic) *)\n remaining_allowed_missed_slots : int;\n (** Remaining amount of endorsing slots that can be missed in the\n cycle before forfeiting the rewards. (dynamic) *)\n expected_endorsing_rewards : Tez_repr.t;\n (** Endorsing rewards that will be distributed at the end of the\n cycle if activity at that point will be greater than the minimal\n required. If the activity is already known to be below the\n required minimum, then the rewards are zero. (dynamic) *)\n}\n\n(** Only use this function for RPC: this is expensive.\n\n [delegate_participation_info] and [!val:check_delegate] forms the\n implementation of RPC call \"/context/delegates/<pkh>/participation\".\n *)\nval participation_info :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n participation_info tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 G.B. Fefe, <gb.fefe@protonmail.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nlet expected_slots_for_given_active_stake ctxt ~total_active_stake ~active_stake\n =\n let blocks_per_cycle =\n Int32.to_int (Constants_storage.blocks_per_cycle ctxt)\n in\n let consensus_committee_size =\n Constants_storage.consensus_committee_size ctxt\n in\n let number_of_endorsements_per_cycle =\n blocks_per_cycle * consensus_committee_size\n in\n Z.to_int\n (Z.div\n (Z.mul\n (Z.of_int64 (Tez_repr.to_mutez active_stake))\n (Z.of_int number_of_endorsements_per_cycle))\n (Z.of_int64 (Tez_repr.to_mutez total_active_stake)))\n\ntype level_participation = Participated | Didn't_participate\n\n(* Note that the participation for the last block of a cycle is\n recorded in the next cycle. *)\nlet record_endorsing_participation ctxt ~delegate ~participation\n ~endorsing_power =\n match participation with\n | Participated -> Stake_storage.set_active ctxt delegate\n | Didn't_participate -> (\n let contract = Contract_repr.Implicit delegate in\n Storage.Contract.Missed_endorsements.find ctxt contract >>=? function\n | Some {remaining_slots; missed_levels} ->\n let remaining_slots = remaining_slots - endorsing_power in\n Storage.Contract.Missed_endorsements.update\n ctxt\n contract\n {remaining_slots; missed_levels = missed_levels + 1}\n | None -> (\n let level = Level_storage.current ctxt in\n Raw_context.stake_distribution_for_current_cycle ctxt\n >>?= fun stake_distribution ->\n match\n Signature.Public_key_hash.Map.find delegate stake_distribution\n with\n | None ->\n (* This happens when the block is the first one in a\n cycle, and therefore the endorsements are for the last\n block of the previous cycle, and when the delegate does\n not have an active stake at the current cycle; in this\n case its participation is simply ignored. *)\n assert (Compare.Int32.(level.cycle_position = 0l)) ;\n return ctxt\n | Some active_stake ->\n Stake_storage.get_total_active_stake ctxt level.cycle\n >>=? fun total_active_stake ->\n let expected_slots =\n expected_slots_for_given_active_stake\n ctxt\n ~total_active_stake\n ~active_stake\n in\n let Ratio_repr.{numerator; denominator} =\n Constants_storage.minimal_participation_ratio ctxt\n in\n let minimal_activity = expected_slots * numerator / denominator in\n let maximal_inactivity = expected_slots - minimal_activity in\n let remaining_slots = maximal_inactivity - endorsing_power in\n Storage.Contract.Missed_endorsements.init\n ctxt\n contract\n {remaining_slots; missed_levels = 1}))\n\nlet record_baking_activity_and_pay_rewards_and_fees ctxt ~payload_producer\n ~block_producer ~baking_reward ~reward_bonus =\n Stake_storage.set_active ctxt payload_producer >>=? fun ctxt ->\n (if not (Signature.Public_key_hash.equal payload_producer block_producer) then\n Stake_storage.set_active ctxt block_producer\n else return ctxt)\n >>=? fun ctxt ->\n let pay_payload_producer ctxt delegate =\n let contract = Contract_repr.Implicit delegate in\n Token.balance ctxt `Block_fees >>=? fun (ctxt, block_fees) ->\n Token.transfer_n\n ctxt\n [(`Block_fees, block_fees); (`Baking_rewards, baking_reward)]\n (`Contract contract)\n in\n let pay_block_producer ctxt delegate bonus =\n let contract = Contract_repr.Implicit delegate in\n Token.transfer ctxt `Baking_bonuses (`Contract contract) bonus\n in\n pay_payload_producer ctxt payload_producer\n >>=? fun (ctxt, balance_updates_payload_producer) ->\n (match reward_bonus with\n | Some bonus -> pay_block_producer ctxt block_producer bonus\n | None -> return (ctxt, []))\n >>=? fun (ctxt, balance_updates_block_producer) ->\n return\n (ctxt, balance_updates_payload_producer @ balance_updates_block_producer)\n\nlet check_and_reset_delegate_participation ctxt delegate =\n let contract = Contract_repr.Implicit delegate in\n Storage.Contract.Missed_endorsements.find ctxt contract >>=? fun missed ->\n match missed with\n | None -> return (ctxt, true)\n | Some missed_endorsements ->\n Storage.Contract.Missed_endorsements.remove ctxt contract >>= fun ctxt ->\n return (ctxt, Compare.Int.(missed_endorsements.remaining_slots >= 0))\n\ntype participation_info = {\n expected_cycle_activity : int;\n minimal_cycle_activity : int;\n missed_slots : int;\n missed_levels : int;\n remaining_allowed_missed_slots : int;\n expected_endorsing_rewards : Tez_repr.t;\n}\n\n(* Inefficient, only for RPC *)\nlet participation_info ctxt delegate =\n let level = Level_storage.current ctxt in\n Stake_storage.get_selected_distribution ctxt level.cycle\n >>=? fun stake_distribution ->\n match\n List.assoc_opt\n ~equal:Signature.Public_key_hash.equal\n delegate\n stake_distribution\n with\n | None ->\n (* delegate does not have an active stake at the current cycle *)\n return\n {\n expected_cycle_activity = 0;\n minimal_cycle_activity = 0;\n missed_slots = 0;\n missed_levels = 0;\n remaining_allowed_missed_slots = 0;\n expected_endorsing_rewards = Tez_repr.zero;\n }\n | Some active_stake ->\n Stake_storage.get_total_active_stake ctxt level.cycle\n >>=? fun total_active_stake ->\n let expected_cycle_activity =\n expected_slots_for_given_active_stake\n ctxt\n ~total_active_stake\n ~active_stake\n in\n let Ratio_repr.{numerator; denominator} =\n Constants_storage.minimal_participation_ratio ctxt\n in\n let endorsing_reward_per_slot =\n Constants_storage.endorsing_reward_per_slot ctxt\n in\n let minimal_cycle_activity =\n expected_cycle_activity * numerator / denominator\n in\n let maximal_cycle_inactivity =\n expected_cycle_activity - minimal_cycle_activity\n in\n let expected_endorsing_rewards =\n Tez_repr.mul_exn endorsing_reward_per_slot expected_cycle_activity\n in\n let contract = Contract_repr.Implicit delegate in\n Storage.Contract.Missed_endorsements.find ctxt contract\n >>=? fun missed_endorsements ->\n let missed_slots, missed_levels, remaining_allowed_missed_slots =\n match missed_endorsements with\n | None -> (0, 0, maximal_cycle_inactivity)\n | Some {remaining_slots; missed_levels} ->\n ( maximal_cycle_inactivity - remaining_slots,\n missed_levels,\n Compare.Int.max 0 remaining_slots )\n in\n let expected_endorsing_rewards =\n match missed_endorsements with\n | Some r when Compare.Int.(r.remaining_slots < 0) -> Tez_repr.zero\n | _ -> expected_endorsing_rewards\n in\n return\n {\n expected_cycle_activity;\n minimal_cycle_activity;\n missed_slots;\n missed_levels;\n remaining_allowed_missed_slots;\n expected_endorsing_rewards;\n }\n" ;
} ;
{ name = "Delegate_slashed_deposits_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 G.B. Fefe, <gb.fefe@protonmail.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module maintains the storage related to slashing of delegates for\n double signing. In particular, it is responsible for maintaining the\n {!Storage.Slashed_deposits} table. *)\n\n(** Returns true if the given delegate has already been slashed\n for double baking for the given level. *)\nval already_slashed_for_double_baking :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Level_repr.t ->\n bool tzresult Lwt.t\n\n(** Returns true if the given delegate has already been slashed\n for double preendorsing or double endorsing for the given level. *)\nval already_slashed_for_double_endorsing :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Level_repr.t ->\n bool tzresult Lwt.t\n\n(** Burn some frozen deposit for a delegate at a given level and\n record in the context that the given delegate has now been slashed\n for double endorsing for the given level.\n\n Returns the burned amount.\n\n Fails with [Unrequired_denunciation] if the given delegate has\n already been slashed for double endorsing for the given level. *)\nval punish_double_endorsing :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Level_repr.t ->\n (Raw_context.t * Tez_repr.t * Receipt_repr.balance_updates) tzresult Lwt.t\n\n(** Burn some frozen deposit for a delegate at a given level and\n record in the context that the given delegate has now been slashed\n for double baking for the given level.\n\n Returns the burned amount.\n\n Fails with [Unrequired_denunciation] if the given delegate has\n already been slashed for double baking for the given level. *)\nval punish_double_baking :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Level_repr.t ->\n (Raw_context.t * Tez_repr.t * Receipt_repr.balance_updates) tzresult Lwt.t\n\nval clear_outdated_slashed_deposits :\n Raw_context.t -> new_cycle:Cycle_repr.t -> Raw_context.t Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 G.B. Fefe, <gb.fefe@protonmail.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nlet already_slashed_for_double_endorsing ctxt delegate (level : Level_repr.t) =\n Storage.Slashed_deposits.find (ctxt, level.cycle) (level.level, delegate)\n >>=? function\n | None -> return_false\n | Some slashed -> return slashed.for_double_endorsing\n\nlet already_slashed_for_double_baking ctxt delegate (level : Level_repr.t) =\n Storage.Slashed_deposits.find (ctxt, level.cycle) (level.level, delegate)\n >>=? function\n | None -> return_false\n | Some slashed -> return slashed.for_double_baking\n\nlet punish_double_endorsing ctxt delegate (level : Level_repr.t) =\n let open Lwt_result_syntax in\n let* slashed =\n Storage.Slashed_deposits.find (ctxt, level.cycle) (level.level, delegate)\n in\n let updated_slashed =\n match slashed with\n | None -> {Storage.for_double_endorsing = true; for_double_baking = false}\n | Some slashed ->\n assert (Compare.Bool.(slashed.for_double_endorsing = false)) ;\n {slashed with for_double_endorsing = true}\n in\n let delegate_contract = Contract_repr.Implicit delegate in\n let* frozen_deposits = Frozen_deposits_storage.get ctxt delegate_contract in\n let slashing_ratio : Ratio_repr.t =\n Constants_storage.ratio_of_frozen_deposits_slashed_per_double_endorsement\n ctxt\n in\n let punish_value =\n Tez_repr.(\n div_exn\n (mul_exn frozen_deposits.initial_amount slashing_ratio.numerator)\n slashing_ratio.denominator)\n in\n let amount_to_burn =\n Tez_repr.(min frozen_deposits.current_amount punish_value)\n in\n let* ctxt, balance_updates =\n Token.transfer\n ctxt\n (`Frozen_deposits delegate)\n `Double_signing_punishments\n amount_to_burn\n in\n let* ctxt = Stake_storage.remove_stake ctxt delegate amount_to_burn in\n let*! ctxt =\n Storage.Slashed_deposits.add\n (ctxt, level.cycle)\n (level.level, delegate)\n updated_slashed\n in\n return (ctxt, amount_to_burn, balance_updates)\n\nlet punish_double_baking ctxt delegate (level : Level_repr.t) =\n let open Lwt_result_syntax in\n let* slashed =\n Storage.Slashed_deposits.find (ctxt, level.cycle) (level.level, delegate)\n in\n let updated_slashed =\n match slashed with\n | None -> {Storage.for_double_baking = true; for_double_endorsing = false}\n | Some slashed ->\n assert (Compare.Bool.(slashed.for_double_baking = false)) ;\n {slashed with for_double_baking = true}\n in\n let delegate_contract = Contract_repr.Implicit delegate in\n let* frozen_deposits = Frozen_deposits_storage.get ctxt delegate_contract in\n let slashing_for_one_block =\n Constants_storage.double_baking_punishment ctxt\n in\n let amount_to_burn =\n Tez_repr.(min frozen_deposits.current_amount slashing_for_one_block)\n in\n let* ctxt, balance_updates =\n Token.transfer\n ctxt\n (`Frozen_deposits delegate)\n `Double_signing_punishments\n amount_to_burn\n in\n let* ctxt = Stake_storage.remove_stake ctxt delegate amount_to_burn in\n let*! ctxt =\n Storage.Slashed_deposits.add\n (ctxt, level.cycle)\n (level.level, delegate)\n updated_slashed\n in\n return (ctxt, amount_to_burn, balance_updates)\n\nlet clear_outdated_slashed_deposits ctxt ~new_cycle =\n let max_slashable_period = Constants_storage.max_slashing_period ctxt in\n match Cycle_repr.(sub new_cycle max_slashable_period) with\n | None -> Lwt.return ctxt\n | Some outdated_cycle -> Storage.Slashed_deposits.clear (ctxt, outdated_cycle)\n" ;
} ;
{ name = "Delegate_cycles" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 G.B. Fefe, <gb.fefe@protonmail.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Per-cycle management of delegates. *)\n\n(** Trigger the context maintenance at the end of cycle 'n', i.e.:\n unfreeze the endorsing rewards, potentially deactivate delegates.\n Return the corresponding balances updates and the list of\n deactivated delegates. *)\nval cycle_end :\n Raw_context.t ->\n Cycle_repr.t ->\n (Raw_context.t\n * Receipt_repr.balance_updates\n * Signature.Public_key_hash.t list)\n tzresult\n Lwt.t\n\n(** [init_first_cycles ctxt ~origin] computes and records the distribution of\n the total active stake among active delegates. This concerns the total\n active stake involved in the calculation of baking rights for all cycles\n in the range [0, preserved_cycles]. It also freezes the deposits for all\n the active delegates. *)\nval init_first_cycles :\n Raw_context.t ->\n origin:Receipt_repr.update_origin ->\n (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 G.B. Fefe, <gb.fefe@protonmail.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nlet update_activity ctxt last_cycle =\n let preserved = Constants_storage.preserved_cycles ctxt in\n match Cycle_repr.sub last_cycle preserved with\n | None -> return (ctxt, [])\n | Some _unfrozen_cycle ->\n Stake_storage.fold_on_active_delegates_with_minimal_stake\n ctxt\n ~order:`Sorted\n ~init:(Ok (ctxt, []))\n ~f:(fun delegate () acc ->\n acc >>?= fun (ctxt, deactivated) ->\n Delegate_activation_storage.last_cycle_before_deactivation\n ctxt\n delegate\n >>=? fun cycle ->\n if Cycle_repr.(cycle <= last_cycle) then\n Stake_storage.set_inactive ctxt delegate >>= fun ctxt ->\n return (ctxt, delegate :: deactivated)\n else return (ctxt, deactivated))\n >|=? fun (ctxt, deactivated) -> (ctxt, deactivated)\n\n(* Return a map from delegates (with active stake at some cycle\n in the cycle window [from_cycle, to_cycle]) to the maximum\n of the stake to be deposited for each such cycle (which is just the\n [frozen_deposits_percentage] of the active stake at that cycle). Also\n return the delegates that have fallen out of the sliding window. *)\nlet max_frozen_deposits_and_delegates_to_remove ctxt ~from_cycle ~to_cycle =\n let frozen_deposits_percentage =\n Constants_storage.frozen_deposits_percentage ctxt\n in\n let cycles = Cycle_repr.(from_cycle ---> to_cycle) in\n (match Cycle_repr.pred from_cycle with\n | None -> return Signature.Public_key_hash.Set.empty\n | Some cleared_cycle -> (\n Stake_storage.find_selected_distribution ctxt cleared_cycle\n >|=? fun cleared_cycle_delegates ->\n match cleared_cycle_delegates with\n | None -> Signature.Public_key_hash.Set.empty\n | Some delegates ->\n List.fold_left\n (fun set (d, _) -> Signature.Public_key_hash.Set.add d set)\n Signature.Public_key_hash.Set.empty\n delegates))\n >>=? fun cleared_cycle_delegates ->\n List.fold_left_es\n (fun (maxima, delegates_to_remove) (cycle : Cycle_repr.t) ->\n Stake_storage.get_selected_distribution ctxt cycle\n >|=? fun active_stakes ->\n List.fold_left\n (fun (maxima, delegates_to_remove) (delegate, stake) ->\n let stake_to_be_deposited =\n Tez_repr.(div_exn (mul_exn stake frozen_deposits_percentage) 100)\n in\n let maxima =\n Signature.Public_key_hash.Map.update\n delegate\n (function\n | None -> Some stake_to_be_deposited\n | Some maximum ->\n Some (Tez_repr.max maximum stake_to_be_deposited))\n maxima\n in\n let delegates_to_remove =\n Signature.Public_key_hash.Set.remove delegate delegates_to_remove\n in\n (maxima, delegates_to_remove))\n (maxima, delegates_to_remove)\n active_stakes)\n (Signature.Public_key_hash.Map.empty, cleared_cycle_delegates)\n cycles\n\nlet freeze_deposits ?(origin = Receipt_repr.Block_application) ctxt ~new_cycle\n ~balance_updates =\n let max_slashable_period = Constants_storage.max_slashing_period ctxt in\n (* We want to be able to slash for at most [max_slashable_period] *)\n (match Cycle_repr.(sub new_cycle (max_slashable_period - 1)) with\n | None ->\n Storage.Tenderbake.First_level_of_protocol.get ctxt\n >>=? fun first_level_of_protocol ->\n let cycle_eras = Raw_context.cycle_eras ctxt in\n let level =\n Level_repr.level_from_raw ~cycle_eras first_level_of_protocol\n in\n return level.cycle\n | Some cycle -> return cycle)\n >>=? fun from_cycle ->\n let preserved_cycles = Constants_storage.preserved_cycles ctxt in\n let to_cycle = Cycle_repr.(add new_cycle preserved_cycles) in\n max_frozen_deposits_and_delegates_to_remove ctxt ~from_cycle ~to_cycle\n >>=? fun (maxima, delegates_to_remove) ->\n Signature.Public_key_hash.Map.fold_es\n (fun delegate maximum_stake_to_be_deposited (ctxt, balance_updates) ->\n (* Here we make sure to preserve the following invariant :\n maximum_stake_to_be_deposited <= frozen_deposits + balance\n See select_distribution_for_cycle *)\n let delegate_contract = Contract_repr.Implicit delegate in\n Frozen_deposits_storage.update_initial_amount\n ctxt\n delegate_contract\n maximum_stake_to_be_deposited\n >>=? fun ctxt ->\n Frozen_deposits_storage.get ctxt delegate_contract >>=? fun deposits ->\n let current_amount = deposits.current_amount in\n if Tez_repr.(current_amount > maximum_stake_to_be_deposited) then\n Tez_repr.(current_amount -? maximum_stake_to_be_deposited)\n >>?= fun to_reimburse ->\n Token.transfer\n ~origin\n ctxt\n (`Frozen_deposits delegate)\n (`Delegate_balance delegate)\n to_reimburse\n >|=? fun (ctxt, bupds) -> (ctxt, bupds @ balance_updates)\n else if Tez_repr.(current_amount < maximum_stake_to_be_deposited) then\n Tez_repr.(maximum_stake_to_be_deposited -? current_amount)\n >>?= fun desired_to_freeze ->\n Delegate_storage.spendable_balance ctxt delegate >>=? fun balance ->\n (* In case the delegate hasn't been slashed in this cycle,\n the following invariant holds:\n maximum_stake_to_be_deposited <= frozen_deposits + balance\n See select_distribution_for_cycle\n\n If the delegate has been slashed during the cycle, the invariant\n above doesn't necessarily hold. In this case, we freeze the max\n we can for the delegate. *)\n let to_freeze = Tez_repr.(min balance desired_to_freeze) in\n Token.transfer\n ~origin\n ctxt\n (`Delegate_balance delegate)\n (`Frozen_deposits delegate)\n to_freeze\n >|=? fun (ctxt, bupds) -> (ctxt, bupds @ balance_updates)\n else return (ctxt, balance_updates))\n maxima\n (ctxt, balance_updates)\n >>=? fun (ctxt, balance_updates) ->\n (* Unfreeze deposits (that is, set them to zero) for delegates that\n were previously in the relevant window (and therefore had some\n frozen deposits) but are not in the new window; because that means\n that such a delegate had no active stake in the relevant cycles,\n and therefore it should have no frozen deposits. *)\n Signature.Public_key_hash.Set.fold_es\n (fun delegate (ctxt, balance_updates) ->\n let delegate_contract = Contract_repr.Implicit delegate in\n Frozen_deposits_storage.update_initial_amount\n ctxt\n delegate_contract\n Tez_repr.zero\n >>=? fun ctxt ->\n Frozen_deposits_storage.get ctxt delegate_contract\n >>=? fun frozen_deposits ->\n if Tez_repr.(frozen_deposits.current_amount > zero) then\n Token.transfer\n ~origin\n ctxt\n (`Frozen_deposits delegate)\n (`Delegate_balance delegate)\n frozen_deposits.current_amount\n >|=? fun (ctxt, bupds) -> (ctxt, bupds @ balance_updates)\n else return (ctxt, balance_updates))\n delegates_to_remove\n (ctxt, balance_updates)\n\nlet delegate_has_revealed_nonces delegate unrevelead_nonces_set =\n not (Signature.Public_key_hash.Set.mem delegate unrevelead_nonces_set)\n\nlet distribute_endorsing_rewards ctxt last_cycle unrevealed_nonces =\n let endorsing_reward_per_slot =\n Constants_storage.endorsing_reward_per_slot ctxt\n in\n let unrevealed_nonces_set =\n List.fold_left\n (fun set {Storage.Seed.nonce_hash = _; delegate} ->\n Signature.Public_key_hash.Set.add delegate set)\n Signature.Public_key_hash.Set.empty\n unrevealed_nonces\n in\n Stake_storage.get_total_active_stake ctxt last_cycle\n >>=? fun total_active_stake ->\n Stake_storage.get_selected_distribution ctxt last_cycle >>=? fun delegates ->\n List.fold_left_es\n (fun (ctxt, balance_updates) (delegate, active_stake) ->\n let delegate_contract = Contract_repr.Implicit delegate in\n Delegate_missed_endorsements_storage\n .check_and_reset_delegate_participation\n ctxt\n delegate\n >>=? fun (ctxt, sufficient_participation) ->\n let has_revealed_nonces =\n delegate_has_revealed_nonces delegate unrevealed_nonces_set\n in\n let expected_slots =\n Delegate_missed_endorsements_storage\n .expected_slots_for_given_active_stake\n ctxt\n ~total_active_stake\n ~active_stake\n in\n let rewards = Tez_repr.mul_exn endorsing_reward_per_slot expected_slots in\n if sufficient_participation && has_revealed_nonces then\n (* Sufficient participation: we pay the rewards *)\n Token.transfer\n ctxt\n `Endorsing_rewards\n (`Contract delegate_contract)\n rewards\n >|=? fun (ctxt, payed_rewards_receipts) ->\n (ctxt, payed_rewards_receipts @ balance_updates)\n else\n (* Insufficient participation or unrevealed nonce: no rewards *)\n Token.transfer\n ctxt\n `Endorsing_rewards\n (`Lost_endorsing_rewards\n (delegate, not sufficient_participation, not has_revealed_nonces))\n rewards\n >|=? fun (ctxt, payed_rewards_receipts) ->\n (ctxt, payed_rewards_receipts @ balance_updates))\n (ctxt, [])\n delegates\n\nlet cycle_end ctxt last_cycle =\n Seed_storage.cycle_end ctxt last_cycle >>=? fun (ctxt, unrevealed_nonces) ->\n let new_cycle = Cycle_repr.add last_cycle 1 in\n Delegate_sampler.select_new_distribution_at_cycle_end ctxt ~new_cycle\n >>=? fun ctxt ->\n Delegate_consensus_key.activate ctxt ~new_cycle >>=? fun ctxt ->\n Delegate_slashed_deposits_storage.clear_outdated_slashed_deposits\n ctxt\n ~new_cycle\n >>= fun ctxt ->\n distribute_endorsing_rewards ctxt last_cycle unrevealed_nonces\n >>=? fun (ctxt, balance_updates) ->\n freeze_deposits ctxt ~new_cycle ~balance_updates\n >>=? fun (ctxt, balance_updates) ->\n Stake_storage.clear_at_cycle_end ctxt ~new_cycle >>=? fun ctxt ->\n Delegate_sampler.clear_outdated_sampling_data ctxt ~new_cycle >>=? fun ctxt ->\n update_activity ctxt last_cycle >>=? fun (ctxt, deactivated_delagates) ->\n return (ctxt, balance_updates, deactivated_delagates)\n\nlet init_first_cycles ctxt ~origin =\n let preserved = Constants_storage.preserved_cycles ctxt in\n List.fold_left_es\n (fun ctxt c ->\n let cycle = Cycle_repr.of_int32_exn (Int32.of_int c) in\n Stake_storage.snapshot ctxt >>=? fun ctxt ->\n (* NB: we need to take several snapshots because\n select_distribution_for_cycle deletes the snapshots *)\n Delegate_sampler.select_distribution_for_cycle ctxt cycle)\n ctxt\n Misc.(0 --> preserved)\n >>=? fun ctxt ->\n let cycle = (Raw_context.current_level ctxt).cycle in\n freeze_deposits ~origin ~new_cycle:cycle ~balance_updates:[] ctxt\n" ;
} ;
{ name = "Bootstrap_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module provides functions that can be used in a private network to\n delay initial rewarding, typically when waiting for more bakers to join the\n network. *)\n\nval init :\n Raw_context.t ->\n typecheck:\n (Raw_context.t ->\n Script_repr.t ->\n ((Script_repr.t * Lazy_storage_diff.diffs option) * Raw_context.t) tzresult\n Lwt.t) ->\n ?no_reward_cycles:int ->\n Parameters_repr.bootstrap_account list ->\n Parameters_repr.bootstrap_contract list ->\n (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t\n\nval cycle_end : Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error += Unrevealed_public_key of Signature.Public_key_hash.t\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"bootstrap.unrevealed_public_key\"\n ~title:\"Forbidden delegation from unrevealed public key\"\n ~description:\"Tried to delegate from an unrevealed public key\"\n ~pp:(fun ppf delegate ->\n Format.fprintf\n ppf\n \"Delegation from an unrevealed public key (for %a) is forbidden.\"\n Signature.Public_key_hash.pp\n delegate)\n Data_encoding.(obj1 (req \"delegator\" Signature.Public_key_hash.encoding))\n (function Unrevealed_public_key pkh -> Some pkh | _ -> None)\n (fun pkh -> Unrevealed_public_key pkh)\n\nlet init_account (ctxt, balance_updates)\n ({public_key_hash; public_key; amount; delegate_to; consensus_key} :\n Parameters_repr.bootstrap_account) =\n let contract = Contract_repr.Implicit public_key_hash in\n Token.transfer\n ~origin:Protocol_migration\n ctxt\n `Bootstrap\n (`Contract contract)\n amount\n >>=? fun (ctxt, new_balance_updates) ->\n (match public_key with\n | Some public_key -> (\n Contract_manager_storage.reveal_manager_key\n ctxt\n public_key_hash\n public_key\n >>=? fun ctxt ->\n Delegate_storage.Contract.set\n ctxt\n contract\n (Some (Option.value ~default:public_key_hash delegate_to))\n >>=? fun ctxt ->\n match consensus_key with\n | None -> return ctxt\n | Some consensus_key ->\n Delegate_consensus_key.init ctxt public_key_hash consensus_key)\n | None ->\n fail_when\n (Option.is_some delegate_to)\n (Unrevealed_public_key public_key_hash)\n >>=? fun () -> return ctxt)\n >|=? fun ctxt -> (ctxt, new_balance_updates @ balance_updates)\n\nlet init_contract ~typecheck (ctxt, balance_updates)\n ({delegate; amount; script} : Parameters_repr.bootstrap_contract) =\n Contract_storage.fresh_contract_from_current_nonce ctxt\n >>?= fun (ctxt, contract_hash) ->\n typecheck ctxt script >>=? fun (script, ctxt) ->\n Contract_storage.raw_originate\n ctxt\n ~prepaid_bootstrap_storage:true\n contract_hash\n ~script\n >>=? fun ctxt ->\n let contract = Contract_repr.Originated contract_hash in\n (match delegate with\n | None -> return ctxt\n | Some delegate -> Delegate_storage.Contract.init ctxt contract delegate)\n >>=? fun ctxt ->\n let origin = Receipt_repr.Protocol_migration in\n Token.transfer ~origin ctxt `Bootstrap (`Contract contract) amount\n >|=? fun (ctxt, new_balance_updates) ->\n (ctxt, new_balance_updates @ balance_updates)\n\nlet init ctxt ~typecheck ?no_reward_cycles accounts contracts =\n let nonce = Operation_hash.hash_string [\"Un festival de GADT.\"] in\n let ctxt = Raw_context.init_origination_nonce ctxt nonce in\n List.fold_left_es init_account (ctxt, []) accounts\n >>=? fun (ctxt, balance_updates) ->\n List.fold_left_es (init_contract ~typecheck) (ctxt, balance_updates) contracts\n >>=? fun (ctxt, balance_updates) ->\n (match no_reward_cycles with\n | None -> return ctxt\n | Some cycles ->\n (* Store pending ramp ups. *)\n let constants = Raw_context.constants ctxt in\n (* Start without rewards *)\n Raw_context.patch_constants ctxt (fun c ->\n {\n c with\n baking_reward_fixed_portion = Tez_repr.zero;\n baking_reward_bonus_per_slot = Tez_repr.zero;\n endorsing_reward_per_slot = Tez_repr.zero;\n })\n >>= fun ctxt ->\n (* Store the final reward. *)\n Storage.Ramp_up.(\n Rewards.init\n ctxt\n (Cycle_repr.of_int32_exn (Int32.of_int cycles))\n {\n baking_reward_fixed_portion = constants.baking_reward_fixed_portion;\n baking_reward_bonus_per_slot =\n constants.baking_reward_bonus_per_slot;\n endorsing_reward_per_slot = constants.endorsing_reward_per_slot;\n }))\n >|=? fun ctxt -> (ctxt, balance_updates)\n\nlet cycle_end ctxt last_cycle =\n let next_cycle = Cycle_repr.succ last_cycle in\n Storage.Ramp_up.Rewards.find ctxt next_cycle >>=? function\n | None -> return ctxt\n | Some\n Storage.Ramp_up.\n {\n baking_reward_fixed_portion;\n baking_reward_bonus_per_slot;\n endorsing_reward_per_slot;\n } ->\n Storage.Ramp_up.Rewards.remove_existing ctxt next_cycle >>=? fun ctxt ->\n Raw_context.patch_constants ctxt (fun c ->\n {\n c with\n baking_reward_fixed_portion;\n baking_reward_bonus_per_slot;\n endorsing_reward_per_slot;\n })\n >|= ok\n" ;
} ;
{ name = "Vote_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Manages all the voting related storage in Storage.Vote. *)\n\n(** [get_delegate_proposal_count ctxt proposer] returns the number of\n proposals already made by [proposer] in the current voting cycle.\n\n This number of proposals, aka [count], has its own storage bucket.\n\n @return [0] if the [count] of the proposer was not initialized.\n\n @return [Error Storage_error] if the deserialization of [count]\n fails. *)\nval get_delegate_proposal_count :\n Raw_context.t -> Signature.public_key_hash -> int tzresult Lwt.t\n\n(** [set_delegate_proposal_count ctxt proposer count] sets\n [proposer]'s number of submitted proposals to [count].\n\n More precisely, the relevant storage bucket is allocated and\n initialized to [count] if it didn't exist; otherwise it is simply\n updated. *)\nval set_delegate_proposal_count :\n Raw_context.t -> Signature.public_key_hash -> int -> Raw_context.t Lwt.t\n\n(** [has_proposed ctxt proposer proposal] indicates whether the\n [proposer] has already proposed the [proposal]. *)\nval has_proposed :\n Raw_context.t -> Signature.public_key_hash -> Protocol_hash.t -> bool Lwt.t\n\n(** [add_proposal ctxt proposer proposal] records the submission of\n [proposal] by [proposer]. *)\nval add_proposal :\n Raw_context.t ->\n Signature.public_key_hash ->\n Protocol_hash.t ->\n Raw_context.t Lwt.t\n\n(** Computes for each proposal how many delegates proposed it. *)\nval get_proposals : Raw_context.t -> int64 Protocol_hash.Map.t tzresult Lwt.t\n\nval clear_proposals : Raw_context.t -> Raw_context.t Lwt.t\n\n(** Counts of the votes *)\ntype ballots = {yay : int64; nay : int64; pass : int64}\n\n(** All vote counts set to zero. *)\nval ballots_zero : ballots\n\n(** Encoding for {!ballots}. *)\nval ballots_encoding : ballots Data_encoding.t\n\n(** Equality check for {!ballots}. *)\nval equal_ballots : ballots -> ballots -> bool\n\n(** Pretty printer for {!ballots}. *)\nval pp_ballots : Format.formatter -> ballots -> unit\n\nval has_recorded_ballot :\n Raw_context.t -> Signature.Public_key_hash.t -> bool Lwt.t\n\n(** Records a vote for a delegate, returns a {!Storage_error Existing_key} if\n the vote was already registered *)\nval record_ballot :\n Raw_context.t ->\n Signature.Public_key_hash.t ->\n Vote_repr.ballot ->\n Raw_context.t tzresult Lwt.t\n\n(** Computes the sum of the current ballots weighted by stake. *)\nval get_ballots : Raw_context.t -> ballots tzresult Lwt.t\n\nval get_ballot_list :\n Raw_context.t -> (Signature.Public_key_hash.t * Vote_repr.ballot) list Lwt.t\n\nval clear_ballots : Raw_context.t -> Raw_context.t Lwt.t\n\nval listings_encoding :\n (Signature.Public_key_hash.t * int64) list Data_encoding.t\n\n(** Populates [!Storage.Vote.Listings] using the currently existing\n staking power and sets `Voting_power_in_listings`. Inactive\n delegates or delegates without the minimal required stake are not\n included in the listings. *)\nval update_listings : Raw_context.t -> Raw_context.t tzresult Lwt.t\n\n(** Verifies the presence of a delegate in the listing. *)\nval in_listings : Raw_context.t -> Signature.Public_key_hash.t -> bool Lwt.t\n\nval get_listings :\n Raw_context.t -> (Signature.Public_key_hash.t * int64) list Lwt.t\n\ntype delegate_info = {\n voting_power : Int64.t option;\n current_ballot : Vote_repr.ballot option;\n current_proposals : Protocol_hash.t list;\n remaining_proposals : int;\n}\n\nval pp_delegate_info : Format.formatter -> delegate_info -> unit\n\nval delegate_info_encoding : delegate_info Data_encoding.t\n\nval get_delegate_info :\n Raw_context.t -> Signature.public_key_hash -> delegate_info tzresult Lwt.t\n\nval get_voting_power_free :\n Raw_context.t -> Signature.public_key_hash -> int64 tzresult Lwt.t\n\nval get_voting_power :\n Raw_context.t ->\n Signature.public_key_hash ->\n (Raw_context.t * int64) tzresult Lwt.t\n\n(** Returns the sum of all voting power in the listings,\n without accounting for gas cost. *)\nval get_total_voting_power_free : Raw_context.t -> int64 tzresult Lwt.t\n\n(** Returns the sum of all voting power in the listings. *)\nval get_total_voting_power :\n Raw_context.t -> (Raw_context.t * int64) tzresult Lwt.t\n\nval get_current_quorum : Raw_context.t -> int32 tzresult Lwt.t\n\nval get_participation_ema : Raw_context.t -> int32 tzresult Lwt.t\n\nval set_participation_ema :\n Raw_context.t -> int32 -> Raw_context.t tzresult Lwt.t\n\n(** Indicates whether there is a current proposal in the storage. *)\nval current_proposal_exists : Raw_context.t -> bool Lwt.t\n\n(** Retrieves the current proposal.\n\n @return [Error Storage_error] if there is no current proposal, or\n if the deserialization fails. *)\nval get_current_proposal : Raw_context.t -> Protocol_hash.t tzresult Lwt.t\n\n(** Retrieves the current proposal.\n\n @return [None] if there is no current proposal.\n\n @return [Error Storage_error] if the deserialization fails. *)\nval find_current_proposal :\n Raw_context.t -> Protocol_hash.t option tzresult Lwt.t\n\n(** Registers a current proposal.\n\n @return [Error (Storage_error Existing_key)] if there was already\n a current proposal. *)\nval init_current_proposal :\n Raw_context.t -> Protocol_hash.t -> Raw_context.t tzresult Lwt.t\n\n(** Removes the current proposal. Does nothing if there was no current\n proposal. *)\nval clear_current_proposal : Raw_context.t -> Raw_context.t Lwt.t\n\n(** Sets the initial quorum to 80% and period kind to proposal. *)\nval init :\n Raw_context.t -> start_position:Int32.t -> Raw_context.t tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nlet get_delegate_proposal_count ctxt proposer =\n Storage.Vote.Proposals_count.find ctxt proposer >|=? Option.value ~default:0\n\nlet set_delegate_proposal_count ctxt proposer count =\n Storage.Vote.Proposals_count.add ctxt proposer count\n\nlet has_proposed ctxt proposer proposal =\n Storage.Vote.Proposals.mem ctxt (proposal, proposer)\n\nlet add_proposal ctxt proposer proposal =\n Storage.Vote.Proposals.add ctxt (proposal, proposer)\n\nlet get_proposals ctxt =\n Storage.Vote.Proposals.fold\n ctxt\n ~order:`Sorted\n ~init:(ok Protocol_hash.Map.empty)\n ~f:(fun (proposal, delegate) acc ->\n (* Assuming the same listings is used at votings *)\n Storage.Vote.Listings.get ctxt delegate >>=? fun weight ->\n Lwt.return\n ( acc >|? fun acc ->\n let previous =\n match Protocol_hash.Map.find proposal acc with\n | None -> 0L\n | Some x -> x\n in\n Protocol_hash.Map.add proposal (Int64.add weight previous) acc ))\n\nlet clear_proposals ctxt =\n Storage.Vote.Proposals_count.clear ctxt >>= fun ctxt ->\n Storage.Vote.Proposals.clear ctxt\n\ntype ballots = {yay : int64; nay : int64; pass : int64}\n\nlet ballots_zero = {yay = 0L; nay = 0L; pass = 0L}\n\nlet ballots_encoding =\n let open Data_encoding in\n conv\n (fun {yay; nay; pass} -> (yay, nay, pass))\n (fun (yay, nay, pass) -> {yay; nay; pass})\n @@ obj3 (req \"yay\" int64) (req \"nay\" int64) (req \"pass\" int64)\n\nlet equal_ballots b1 b2 =\n Int64.(equal b1.yay b2.yay && equal b1.nay b2.nay && equal b1.pass b2.pass)\n\nlet pp_ballots ppf b =\n Format.fprintf ppf \"{ yay = %Ld; nay = %Ld; pass = %Ld }\" b.yay b.nay b.pass\n\nlet has_recorded_ballot = Storage.Vote.Ballots.mem\n\nlet record_ballot = Storage.Vote.Ballots.init\n\nlet get_ballots ctxt =\n Storage.Vote.Ballots.fold\n ctxt\n ~order:`Sorted\n ~f:(fun delegate ballot (ballots : ballots tzresult) ->\n (* Assuming the same listings is used at votings *)\n Storage.Vote.Listings.get ctxt delegate >>=? fun weight ->\n let count = Int64.add weight in\n Lwt.return\n ( ballots >|? fun ballots ->\n match ballot with\n | Yay -> {ballots with yay = count ballots.yay}\n | Nay -> {ballots with nay = count ballots.nay}\n | Pass -> {ballots with pass = count ballots.pass} ))\n ~init:(ok ballots_zero)\n\nlet get_ballot_list = Storage.Vote.Ballots.bindings\n\nlet clear_ballots = Storage.Vote.Ballots.clear\n\nlet listings_encoding =\n Data_encoding.(\n list\n (obj2\n (req \"pkh\" Signature.Public_key_hash.encoding)\n (req \"voting_power\" int64)))\n\nlet update_listings ctxt =\n Storage.Vote.Listings.clear ctxt >>= fun ctxt ->\n Stake_storage.fold\n ctxt\n (ctxt, 0L)\n ~order:`Sorted\n ~f:(fun (delegate, stake) (ctxt, total) ->\n let weight = Tez_repr.to_mutez stake in\n Storage.Vote.Listings.init ctxt delegate weight >>=? fun ctxt ->\n return (ctxt, Int64.add total weight))\n >>=? fun (ctxt, total) ->\n Storage.Vote.Voting_power_in_listings.add ctxt total >>= fun ctxt ->\n return ctxt\n\ntype delegate_info = {\n voting_power : Int64.t option;\n current_ballot : Vote_repr.ballot option;\n current_proposals : Protocol_hash.t list;\n remaining_proposals : int;\n}\n\nlet pp_delegate_info ppf info =\n match info.voting_power with\n | None -> Format.fprintf ppf \"Voting power: none\"\n | Some p -> (\n Format.fprintf\n ppf\n \"Voting power: %a\"\n Tez_repr.pp\n (Tez_repr.of_mutez_exn p) ;\n (match info.current_ballot with\n | None -> ()\n | Some ballot ->\n Format.fprintf ppf \"@,Current ballot: %a\" Vote_repr.pp_ballot ballot) ;\n match info.current_proposals with\n | [] ->\n if Compare.Int.(info.remaining_proposals <> 0) then\n Format.fprintf\n ppf\n \"@,Remaining proposals: %d\"\n info.remaining_proposals\n | proposals ->\n Format.fprintf ppf \"@,@[<v 2>Current proposals:\" ;\n List.iter\n (fun p -> Format.fprintf ppf \"@,- %a\" Protocol_hash.pp p)\n proposals ;\n Format.fprintf ppf \"@]\" ;\n Format.fprintf\n ppf\n \"@,Remaining proposals: %d\"\n info.remaining_proposals)\n\nlet delegate_info_encoding =\n let open Data_encoding in\n conv\n (fun {voting_power; current_ballot; current_proposals; remaining_proposals} ->\n (voting_power, current_ballot, current_proposals, remaining_proposals))\n (fun (voting_power, current_ballot, current_proposals, remaining_proposals) ->\n {voting_power; current_ballot; current_proposals; remaining_proposals})\n (obj4\n (opt \"voting_power\" int64)\n (opt \"current_ballot\" Vote_repr.ballot_encoding)\n (dft \"current_proposals\" (list Protocol_hash.encoding) [])\n (dft \"remaining_proposals\" int31 0))\n\nlet in_listings = Storage.Vote.Listings.mem\n\nlet get_listings = Storage.Vote.Listings.bindings\n\nlet get_delegate_info ctxt delegate =\n Storage.Vote.Listings.find ctxt delegate >>=? fun voting_power ->\n match voting_power with\n | None ->\n return\n {\n voting_power;\n current_proposals = [];\n current_ballot = None;\n remaining_proposals = 0;\n }\n | Some _ ->\n Voting_period_storage.get_current_kind ctxt >>=? fun period ->\n (match period with\n | Exploration | Promotion -> Storage.Vote.Ballots.find ctxt delegate\n | Proposal | Cooldown | Adoption -> return None)\n >>=? fun current_ballot ->\n (match period with\n | Exploration | Promotion | Cooldown | Adoption -> Lwt.return []\n | Proposal ->\n Storage.Vote.Proposals.fold\n ctxt\n ~order:`Undefined\n ~init:[]\n ~f:(fun (h, d) acc ->\n if Signature.Public_key_hash.equal d delegate then\n Lwt.return (h :: acc)\n else Lwt.return acc))\n >>= fun current_proposals ->\n let remaining_proposals =\n match period with\n | Proposal ->\n Constants_repr.max_proposals_per_delegate\n - List.length current_proposals\n | _ -> 0\n in\n return\n {voting_power; current_ballot; current_proposals; remaining_proposals}\n\nlet get_voting_power_free ctxt owner =\n Storage.Vote.Listings.find ctxt owner >|=? Option.value ~default:0L\n\n(* This function bypasses the carbonated functors to account for gas consumption.\n This is a temporary situation intended to be fixed by adding the right\n carbonated functors in a future amendment *)\nlet get_voting_power ctxt owner =\n let open Raw_context in\n (* Always consume read access to memory *)\n (* Accessing an int64 at /votes/listings/<KeyKind>/<hash> *)\n consume_gas ctxt (Storage_costs.read_access ~path_length:4 ~read_bytes:8)\n >>?= fun ctxt ->\n Storage.Vote.Listings.find ctxt owner >|=? function\n | None -> (ctxt, 0L)\n | Some power -> (ctxt, power)\n\nlet get_total_voting_power_free = Storage.Vote.Voting_power_in_listings.get\n\n(* This function bypasses the carbonated functors to account for gas consumption.\n This is a temporary situation intended to be fixed by adding the right\n carbonated functors in a future amendment *)\nlet get_total_voting_power ctxt =\n let open Raw_context in\n (* Accessing an int64 at /votes/total_voting_power *)\n consume_gas ctxt (Storage_costs.read_access ~path_length:2 ~read_bytes:8)\n >>?= fun ctxt ->\n get_total_voting_power_free ctxt >|=? fun total_voting_power ->\n (ctxt, total_voting_power)\n\nlet get_current_quorum ctxt =\n Storage.Vote.Participation_ema.get ctxt >|=? fun participation_ema ->\n let quorum_min = Constants_storage.quorum_min ctxt in\n let quorum_max = Constants_storage.quorum_max ctxt in\n let quorum_diff = Int32.sub quorum_max quorum_min in\n Int32.(add quorum_min (div (mul participation_ema quorum_diff) 100_00l))\n\nlet get_participation_ema = Storage.Vote.Participation_ema.get\n\nlet set_participation_ema = Storage.Vote.Participation_ema.update\n\nlet current_proposal_exists = Storage.Vote.Current_proposal.mem\n\nlet get_current_proposal = Storage.Vote.Current_proposal.get\n\nlet find_current_proposal = Storage.Vote.Current_proposal.find\n\nlet init_current_proposal = Storage.Vote.Current_proposal.init\n\nlet clear_current_proposal = Storage.Vote.Current_proposal.remove\n\nlet init ctxt ~start_position =\n (* participation EMA is in centile of a percentage *)\n let participation_ema = Constants_storage.quorum_max ctxt in\n Storage.Vote.Participation_ema.init ctxt participation_ema >>=? fun ctxt ->\n Voting_period_storage.init_first_period ctxt ~start_position\n" ;
} ;
{ name = "Ticket_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error +=\n | Negative_ticket_balance of {key : Ticket_hash_repr.t; balance : Z.t}\n | Used_storage_space_underflow\n\n(** [get_balance ctxt key] receives the ticket balance for the given\n [key] in the context [ctxt]. The [key] represents a ticket content and a\n ticket creator pair. In case there exists no value for the given [key],\n [None] is returned.\n *)\nval get_balance :\n Raw_context.t ->\n Ticket_hash_repr.t ->\n (Z.t option * Raw_context.t) tzresult Lwt.t\n\n(** [adjust_balance ctxt key ~delta] adjusts the balance of the\n given key (representing a ticket content, creator and owner pair)\n and [delta]. The value of [delta] can be positive as well as negative.\n If there is no pre-exising balance for the given ticket type and owner,\n it is assumed to be 0 and the new balance is [delta]. The function also\n returns the difference between the old and the new size of the storage.\n Note that the difference may be negative. For example, because when\n setting the balance to zero, an entry is removed.\n\n The function fails with a [Negative_ticket_balance] error\n in case the resulting balance is negative.\n *)\nval adjust_balance :\n Raw_context.t ->\n Ticket_hash_repr.t ->\n delta:Z.t ->\n (Z.t * Raw_context.t) tzresult Lwt.t\n\n(** [adjust_storage_space ctxt ~storage_diff] updates the used storage space\n for the ticket-table according to [storage_diff]. The additional positive\n amount of unpaid storage is returned. If no unpaid storage is consumed,\n this amount is 0.\n\n Note that when storage space for the ticket table is released we may later\n use that space for free. For this reason, the amount returned may be less\n than the given (positive) [storage_diff]. *)\nval adjust_storage_space :\n Raw_context.t -> storage_diff:Z.t -> (Z.t * Raw_context.t) tzresult Lwt.t\n\nmodule Internal_for_tests : sig\n (** [used_storage_space ctxt] returns the used ticket storage space. *)\n val used_storage_space : Raw_context.t -> (Z.t, error trace) result Lwt.t\n\n (** [paid_storage_space ctxt] returns the paid ticket storage space. *)\n val paid_storage_space : Raw_context.t -> (Z.t, error trace) result Lwt.t\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error +=\n | Negative_ticket_balance of {key : Ticket_hash_repr.t; balance : Z.t}\n | Used_storage_space_underflow\n\nlet () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"Negative_ticket_balance\"\n ~title:\"Negative ticket balance\"\n ~description:\"Attempted to set a negative ticket balance value\"\n ~pp:(fun ppf (key, balance) ->\n Format.fprintf\n ppf\n \"Attempted to set negative ticket balance value '%a' for key %a.\"\n Z.pp_print\n balance\n Ticket_hash_repr.pp\n key)\n (obj2 (req \"key\" Ticket_hash_repr.encoding) (req \"balance\" Data_encoding.z))\n (function\n | Negative_ticket_balance {key; balance} -> Some (key, balance)\n | _ -> None)\n (fun (key, balance) -> Negative_ticket_balance {key; balance}) ;\n register_error_kind\n `Permanent\n ~id:\"Used_storage_underflow\"\n ~title:\"Ticket balance used storage underflow\"\n ~description:\n \"Attempt to free more bytes than allocated for the tickets balance\"\n empty\n (function Used_storage_space_underflow -> Some () | _ -> None)\n (fun () -> Used_storage_space_underflow)\n\nlet get_balance ctxt key =\n Storage.Ticket_balance.Table.find ctxt key >|=? fun (ctxt, res) -> (res, ctxt)\n\nlet set_balance ctxt key balance =\n let cost_of_key = Z.of_int 65 in\n fail_when\n Compare.Z.(balance < Z.zero)\n (Negative_ticket_balance {key; balance})\n >>=? fun () ->\n if Compare.Z.(balance = Z.zero) then\n Storage.Ticket_balance.Table.remove ctxt key\n >|=? fun (ctxt, freed, existed) ->\n (* If we remove an existing entry, then we return the freed size for\n both the key and the value. *)\n let freed =\n if existed then Z.neg @@ Z.add cost_of_key (Z.of_int freed) else Z.zero\n in\n (freed, ctxt)\n else\n Storage.Ticket_balance.Table.add ctxt key balance\n >|=? fun (ctxt, size_diff, existed) ->\n let size_diff =\n let z_diff = Z.of_int size_diff in\n (* For a new entry we also charge the space for storing the key *)\n if existed then z_diff else Z.add cost_of_key z_diff\n in\n (size_diff, ctxt)\n\nlet adjust_balance ctxt key ~delta =\n get_balance ctxt key >>=? fun (res, ctxt) ->\n let old_balance = Option.value ~default:Z.zero res in\n set_balance ctxt key (Z.add old_balance delta)\n\nlet adjust_storage_space ctxt ~storage_diff =\n if Compare.Z.(storage_diff = Z.zero) then return (Z.zero, ctxt)\n else\n Storage.Ticket_balance.Used_storage_space.find ctxt >>=? fun used_storage ->\n let used_storage = Option.value ~default:Z.zero used_storage in\n Storage.Ticket_balance.Paid_storage_space.find ctxt >>=? fun paid_storage ->\n let paid_storage = Option.value ~default:Z.zero paid_storage in\n let new_used_storage = Z.add used_storage storage_diff in\n error_when\n Compare.Z.(new_used_storage < Z.zero)\n Used_storage_space_underflow\n >>?= fun () ->\n Storage.Ticket_balance.Used_storage_space.add ctxt new_used_storage\n >>= fun ctxt ->\n let diff = Z.sub new_used_storage paid_storage in\n if Compare.Z.(Z.zero < diff) then\n Storage.Ticket_balance.Paid_storage_space.add ctxt new_used_storage\n >>= fun ctxt -> return (diff, ctxt)\n else return (Z.zero, ctxt)\n\nmodule Internal_for_tests = struct\n let used_storage_space c =\n Storage.Ticket_balance.Used_storage_space.find c\n >|=? Option.value ~default:Z.zero\n\n let paid_storage_space c =\n Storage.Ticket_balance.Paid_storage_space.find c\n >|=? Option.value ~default:Z.zero\nend\n" ;
} ;
{ name = "Liquidity_baking_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Tocqueville Group, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Get the address of the Constant-Product Market Maker receiving the \n Liquidity Baking subsidy *)\nval get_cpmm_address : Raw_context.t -> Contract_hash.t tzresult Lwt.t\n\n(** [on_subsidy_allowed ctxt ~toggle_vote f] updates the toggle EMA according to\n [toggle_vote]. Then the callback function [f] is called if the following\n conditions are met:\n - the updated EMA is below the threshold,\n - the CPMM contract exists.\n\n The role of the callback function [f] is to send the subsidy to the CPMM,\n see [apply_liquidity_baking_subsidy] in [apply.ml]. *)\nval on_subsidy_allowed :\n Raw_context.t ->\n toggle_vote:Liquidity_baking_repr.liquidity_baking_toggle_vote ->\n (Raw_context.t -> Contract_hash.t -> (Raw_context.t * 'a list) tzresult Lwt.t) ->\n (Raw_context.t * 'a list * Liquidity_baking_repr.Toggle_EMA.t) tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Tocqueville Group, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Liquidity_baking_repr\n\nlet get_cpmm_address = Storage.Liquidity_baking.Cpmm_address.get\n\nlet get_toggle_ema ctxt =\n Storage.Liquidity_baking.Toggle_ema.get ctxt >>=? fun ema ->\n Toggle_EMA.of_int32 ema\n\nlet on_cpmm_exists ctxt f =\n get_cpmm_address ctxt >>=? fun cpmm_contract ->\n Contract_storage.exists ctxt (Contract_repr.Originated cpmm_contract)\n >>= function\n | false ->\n (* do nothing if the cpmm is not found *)\n return (ctxt, [])\n | true -> f ctxt cpmm_contract\n\nlet update_toggle_ema ctxt ~toggle_vote =\n get_toggle_ema ctxt >>=? fun old_ema ->\n let new_ema = compute_new_ema ~toggle_vote old_ema in\n Storage.Liquidity_baking.Toggle_ema.update ctxt (Toggle_EMA.to_int32 new_ema)\n >|=? fun ctxt -> (ctxt, new_ema)\n\nlet check_ema_below_threshold ctxt ema =\n Toggle_EMA.(\n ema < Constants_storage.liquidity_baking_toggle_ema_threshold ctxt)\n\nlet on_subsidy_allowed ctxt ~toggle_vote f =\n update_toggle_ema ctxt ~toggle_vote >>=? fun (ctxt, toggle_ema) ->\n if check_ema_below_threshold ctxt toggle_ema then\n on_cpmm_exists ctxt f >|=? fun (ctxt, operation_results) ->\n (ctxt, operation_results, toggle_ema)\n else return (ctxt, [], toggle_ema)\n" ;
} ;
{ name = "Liquidity_baking_cpmm" ;
interface = None ;
implementation = "let script_hex : Hex.t =\n `Hex\n \"02000011c405000764076407640865046e00000006256f776e6572076504620000000d256d696e4c71744d696e7465640765046200000013256d6178546f6b656e734465706f7369746564046b0000000925646561646c696e650000000d256164644c6971756964697479046c000000082564656661756c7407640865046e0000000325746f076504620000000a256c71744275726e65640765046a00000010256d696e58747a57697468647261776e0765046200000013256d696e546f6b656e7357697468647261776e046b0000000925646561646c696e65000000102572656d6f76654c69717569646974790865046e00000015256f7574707574446578746572436f6e74726163740765046200000010256d696e546f6b656e73426f756768740765046e0000000325746f076504620000000b25746f6b656e73536f6c64046b0000000925646561646c696e650000000d25746f6b656e546f546f6b656e07640865046e0000000325746f076504620000000b25746f6b656e73536f6c640765046a0000000d256d696e58747a426f75676874046b0000000925646561646c696e650000000b25746f6b656e546f58747a0865046e0000000325746f0765046200000010256d696e546f6b656e73426f75676874046b0000000925646561646c696e650000000b2578747a546f546f6b656e0501076504620000000a25746f6b656e506f6f6c0765046a000000082578747a506f6f6c0765046200000009256c7174546f74616c0765046e0000000d25746f6b656e41646472657373046e0000000b256c71744164647265737305020200000f7203210317034c0316072e02000009d1072e020000035a072e020000032603210317034c0316034c03210317034c0316034c03210317034c0316034c034003190328072c020000000c05200004074303620003032702000002ea0743036a000105700004032105710005031703160322072f0200000013074303680100000008444956206279203003270200000000031603130743036a0001034c0322072f02000000130743036801000000084449562062792030032702000000000316034c0321057100020570000603210571000703170317031605700002032105710003033a0322072f020000001307430368010000000844495620627920300327020000000003160570000205700006032105710007031605700003033a0322072f020000001307430368010000000844495620627920300327020000002a03210317034c03160743036200000570000203190325072c02000000000200000008074303620001031205700002034c0321057100020319032a072c020000000c05200005074303620004032702000001b60571000203210571000303190337072c020000000c0520000407430362000503270200000190057000030321057100040317031703170570000203210571000305700005032105710006031703170316031203420570000403210571000503170316034205700004032105710005031603420317034c032105710002057000050321057100060316031203420321031703170313057000060317031603120342034c03160342034c03490354034203480342034c032105710002034c03210317034c0316034c03210317034c031605700003031703170317031606550765036e0765036e036200000009257472616e73666572072f0200000008074303620000032702000000000743036a000005700003057000030342057000030342034d05700002033005700003034205700002032105710003034c03210317034c031605700002031703170317031706550765045b00000009257175616e74697479046e00000007257461726765740000000b256d696e744f724275726e072f020000000807430362000c032702000000000743036a000005700002057000030342034d05700002053d036d05700002031b05700002031b0342020000002803200321031703170313057000020321057100030317031603120342034c03160342053d036d0342020000066b072e020000038d03210317034c0316034c03210317034c0316034c03210317034c0316034c03210317034c0316034c034003190328072c020000000c05200005074303620003032702000003470743036a000003130319032a072c020000000c0520000507430362000a03270200000323057000040321057100050317031703160743036a000105700006032105710007031703160322072f0200000013074303680100000008444956206279203003270200000000031605700004032105710005033a0322072f020000001307430368010000000844495620627920300327020000000003160743036a0001034c033a0570000503210571000603170317031605700006032105710007031605700005032105710006033a0322072f02000000130743036801000000084449562062792030032702000000000316057000030570000203210571000303190337072c020000000c0520000607430362000b0327020000022e05700002034c03210571000203190337072c020000000c0520000507430362000d032702000002060570000203210571000305700005032105710006031703170316034b0356072f020000000807430362000e03270200000000034c032105710002057000060321057100070316034b0356072f020000000807430362000f03270200000000057000040743035b0000034b0348034205700006032105710007034c03210317034c031605700002031703170317031706550765045b00000009257175616e74697479046e00000007257461726765740000000b256d696e744f724275726e072f020000000807430362000c032702000000000743036a000005700002057000030342034d0570000305700005032105710006034203490354034205700006032105710007034c03210317034c0316034c03210317034c031605700003031703170317031606550765036e0765036e036200000009257472616e73666572072f0200000008074303620000032702000000000743036a000005700003057000030342057000030342034d05700004032105710005057000060555036c072f020000000807430362000903270200000000034c0743036c030b034d0570000603210571000703170317057000060570000703210571000803170316034b034205700006031603420321031703170317057000060342034c032105710002031703160342034c031603420317057000040342053d036d05700002031b05700002031b05700002031b034202000002d203210317034c0316034c03210317034c0316034c03210317034c0316034c03210317034c03160570000406550765046e0000000325746f0765046200000010256d696e546f6b656e73426f75676874046b0000000925646561646c696e650000000b2578747a546f546f6b656e072f020000000807430362001f032702000000000743036a000003130319032a072c020000000c0520000607430362000a0327020000022d05700002032105710003034003190328072c020000000c05200006074303620003032702000002050743036200a70f05700002032105710003033a0743036200a80f057000070321057100080316033a031205700006032105710007031703160743036200a70f05700004032105710005033a033a0322072f020000001307430368010000000844495620627920300327020000000003160743036200a80f0743036200a70f05700002032105710003033a0322072f02000000130743036801000000084449562062792030032702000000000316057000070321057100080317057000040321057100050570000903210571000a031603120342032103170317057000030321057100040570000a03170316034b0342034c031603420570000403490354034203480342034c032105710002034c03210317034c0316034c03210317034c031605700003031703170317031606550765036e0765036e036200000009257472616e73666572072f0200000008074303620000032702000000000743036a000005700003057000030342057000030342034d057000040570000303210571000405700006057000080342057000070342034d0570000305700004034b0743036e0100000024747a314b65326837734464616b484a5168385758345a3337326475314b4368736b7379550555036c072f020000000807430362000903270200000000034c0743036c030b034d05700003053d036d05700002031b05700002031b05700002031b0342020000058d072e02000002cc03210317034c0316034c03210317034c0316034c03210317034c0316034c034003190328072c020000000c05200004074303620003032702000002900743036a000003130319032a072c020000000c0520000407430362000a0327020000026c0743036200a70f05700002032105710003033a0743036200a80f057000050321057100060316033a03120743036a000105700005032105710006031703160322072f020000001307430368010000000844495620627920300327020000000003160743036200a70f05700004032105710005033a033a0322072f020000001307430368010000000844495620627920300327020000000003160743036a0001034c033a0743036200a80f0743036200a70f05700002032105710003033a0322072f0200000013074303680100000008444956206279203003270200000000031605700002034c03210571000203190337072c020000000a032007430362000803270200000000057000020321057100030349035403420348034205700005032105710006034c03210317034c0316034c03210317034c031605700003031703170317031606550765036e0765036e036200000009257472616e73666572072f0200000008074303620000032702000000000743036a000005700003057000030342057000030342034d034c032105710002057000050555036c072f020000000807430362000903270200000000034c0743036c030b034d0570000503210571000603170570000505700006032105710007031603120342032103170317057000050321057100060570000703170316034b0342034c031603420570000305700004034b0743036e0100000024747a314b65326837734464616b484a5168385758345a3337326475314b4368736b7379550555036c072f020000000807430362000903270200000000034c0743036c030b034d034c053d036d05700002031b05700002031b05700002031b034202000002b503210317034c0316034c03210317034c0316034c034003190328072c020000000c05200003074303620003032702000002830743036a000105700003032105710004031703160322072f0200000013074303680100000008444956206279203003270200000000031603130743036a0001034c0322072f020000001307430368010000000844495620627920300327020000000003160743036200a80f0743036200a70f05700002032105710003033a0322072f02000000130743036801000000084449562062792030032702000000000316032105700002034b03110743036200a70f05700002032105710003033a0743036200a80f05700004033a03120570000503210571000603160743036200a70f05700004032105710005033a033a0322072f0200000013074303680100000008444956206279203003270200000000031605700003034c03210571000203190337072c020000000a0320074303620012032702000000000321057000050321057100060316034b0356072f02000000080743036200130327020000000005700005032105710006031703170743036a000105700005033a05700006032105710007031703160312034205700005031603420317034c0342034c057000030342034903540342034c032105710002034c03210317034c0316034c03210317034c031605700003031703170317031606550765036e0765036e036200000009257472616e73666572072f0200000008074303620000032702000000000743036a000005700003057000030342057000030342034d0743036a000105700003033a0743036e0100000024747a314b65326837734464616b484a5168385758345a3337326475314b4368736b7379550555036c072f020000000807430362000903270200000000034c0743036c030b034d05700002053d036d05700002031b05700002031b0342\"\n\nlet script_bytes : Bytes.t option = Hex.to_bytes script_hex\n\nlet script_opt : Script_repr.expr option =\n Option.bind\n script_bytes\n (Data_encoding.Binary.of_bytes_opt Script_repr.expr_encoding)\n\nlet script : Script_repr.expr =\n Option.value_f ~default:(fun () -> assert false) script_opt\n" ;
} ;
{ name = "Liquidity_baking_lqt" ;
interface = None ;
implementation = "let script_hex : Hex.t =\n `Hex\n \"020000070005000764076407640865046e00000008257370656e6465720462000000062576616c75650000000825617070726f766508650865046e00000006256f776e6572046e00000008257370656e646572000000082572657175657374065a0362000000092563616c6c6261636b0000000d25676574416c6c6f77616e636507640865046e00000006256f776e6572065a0362000000092563616c6c6261636b0000000b2567657442616c616e63650865046c000000082572657175657374065a0362000000092563616c6c6261636b0000000f25676574546f74616c537570706c7907640865045b00000009257175616e74697479046e00000007257461726765740000000b256d696e744f724275726e0865046e000000052566726f6d0765046e0000000325746f0462000000062576616c756500000009257472616e73666572050107650861036e03620000000725746f6b656e73076508610765046e00000006256f776e6572046e00000008257370656e64657203620000000b25616c6c6f77616e6365730765046e000000062561646d696e04620000000d25746f74616c5f737570706c7905020200000552032103170743036a000003130319033c072c020000001607430368010000000b446f6e7453656e6454657a03270200000000034c0316072e02000001b2072e0200000132072e02000000e2034c03210571000203170316034c0321057100020316034803420743036200000570000303210571000403170319032a07430362000005700003032105710004057000030321057100040329072f020000000607430362000002000000000319032a0314072c0200000020074303680100000015556e73616665416c6c6f77616e63654368616e676503270200000000057000030321057100040317031705700002057000030317074303620000034c03210571000203190325072c02000000060320053e0362020000000203460570000303500342034c03160342053d036d03420200000044034c032105700002053d036d034c03210571000203170743036a000005700004031703160570000403160329072f02000000060743036200000200000000034d031b03420200000074072e0200000042034c032105700002053d036d034c03210571000203170743036a00000570000403160570000403160329072f02000000060743036200000200000000034d031b03420200000026034c032105700002053d036d034c03170743036a000005700003031703170317034d031b0342020000035e072e020000013c034c03210571000203170317031603480319033c072c02000000140743036801000000094f6e6c7941646d696e03270200000000032103160570000203210571000303160570000203210571000303170329072f0200000006074303620000020000000003120356072f020000003607430368010000002b43616e6e6f74206275726e206d6f7265207468616e207468652074617267657427732062616c616e63652e03270200000000034c032105710002031605700003032105710004031703170317031203110570000303210571000403170570000403160743036200000570000403210571000503190325072c020000000a057000030320053e03620200000006057000030346057000040317035003420321057100020317031703160342034c032105710002031703160342034c03160342053d036d03420200000216034c03210571000203170316057000020321057100030316057000020321057100030316034803190325072c0200000002034c02000000a903480570000303210571000403160342057000030321057100040317031705700003032105710004057000020321057100030329072f02000000060743036200000200000000034b0356072f020000001d0743036801000000124e6f74456e6f756768416c6c6f77616e636503270200000000057000030743036200000570000203210571000303190325072c0200000008034c0320053e03620200000004034c03460570000203500570000203210571000303170317057000020321057100030570000403210571000503160329072f02000000060743036200000200000000034b0356072f020000001b0743036801000000104e6f74456e6f75676842616c616e636503270200000000057000020743036200000570000203210571000303190325072c0200000008034c0320053e03620200000004034c034605700003032105710004031603500570000203210571000303170317034c03210571000205700004032105710005031703160329072f020000000607430362000002000000000312034c0743036200000570000203210571000303190325072c0200000008034c0320053e03620200000004034c034605700003031703160350057000020317034c0342032103170317057000020342034c03160342053d036d0342\"\n\nlet script_bytes : Bytes.t option = Hex.to_bytes script_hex\n\nlet script_opt : Script_repr.expr option =\n Option.bind\n script_bytes\n (Data_encoding.Binary.of_bytes_opt Script_repr.expr_encoding)\n\nlet script : Script_repr.expr =\n Option.value_f ~default:(fun () -> assert false) script_opt\n" ;
} ;
{ name = "Liquidity_baking_migration" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Tocqueville Group, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nval init :\n Raw_context.t ->\n typecheck:\n (Raw_context.t ->\n Script_repr.t ->\n ((Script_repr.t * Lazy_storage_diff.diffs option) * Raw_context.t) tzresult\n Lwt.t) ->\n (Raw_context.t * Migration_repr.origination_result list) tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Tocqueville Group, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module is used to originate contracts for liquidity baking during\n protocol stitching: a CPMM (constant product market making) contract and a\n liquidity token FA1.2 contract, with the storage of each containing the\n other's address.\n\n The CPMM's storage contains a token address, which corresponds to tzBTC when\n originated on mainnet and a reference FA1.2 contract when originated for\n testing.\n\n The test FA1.2 contract uses the same script as the liquidity token. Its\n manager is initialized to the first bootstrap account. Before originating it,\n we make sure we are not on mainnet by both checking for the existence of the\n tzBTC contract and that the level is sufficiently low.\n\n The Michelson and Ligo code, as well as Coq proofs, for the CPMM and\n liquidity token contracts are available here:\n https://gitlab.com/dexter2tz/dexter2tz/-/tree/liquidity_baking\n\n All contracts were generated from Ligo at revision\n 4d10d07ca05abe0f8a5fb97d15267bf5d339d9f4 and converted to OCaml using\n `octez-client convert`.\n*)\n\nopen Michelson_v1_primitives\nopen Micheline\n\nlet null_address =\n Bytes.of_string\n \"\\000\\000\\000\\000\\000\\000\\000\\000\\000\\000\\000\\000\\000\\000\\000\\000\\000\\000\\000\\000\\000\\000\"\n\nlet mainnet_tzBTC_address =\n Contract_hash.of_b58check_exn \"KT1PWx2mnDueood7fEmfbBDKx1D9BAnnXitn\"\n\n(** If token_pool, xtz_pool, or lqt_total are ever zero the CPMM will be\n permanently broken. Therefore, we initialize it with the null address\n registered as a liquidity provider with 1 satoshi tzBTC and 100 mutez\n (roughly the current exchange rate). *)\nlet cpmm_init_storage ~token_address ~lqt_address =\n Script_repr.lazy_expr\n (Micheline.strip_locations\n (Prim\n ( 0,\n D_Pair,\n [\n Int (1, Z.one);\n Int (2, Z.of_int 100);\n Int (3, Z.of_int 100);\n String (4, token_address);\n String (5, lqt_address);\n ],\n [] )))\n\nlet lqt_init_storage cpmm_address =\n Script_repr.lazy_expr\n (Micheline.strip_locations\n (Prim\n ( 0,\n D_Pair,\n [\n Seq\n ( 1,\n [\n Prim\n ( 2,\n D_Elt,\n [Bytes (3, null_address); Int (4, Z.of_int 100)],\n [] );\n ] );\n Seq (5, []);\n String (6, cpmm_address);\n Int (7, Z.of_int 100);\n ],\n [] )))\n\nlet test_fa12_init_storage manager =\n Script_repr.lazy_expr\n (Micheline.strip_locations\n (Prim\n ( 0,\n D_Pair,\n [\n Seq (1, []);\n Seq (2, []);\n String (3, manager);\n Int (4, Z.of_int 10_000);\n ],\n [] )))\n\nlet originate ctxt address_hash ~balance script =\n Contract_storage.raw_originate\n ctxt\n ~prepaid_bootstrap_storage:true\n address_hash\n ~script\n >>=? fun ctxt ->\n let address = Contract_repr.Originated address_hash in\n Contract_storage.used_storage_space ctxt address >>=? fun size ->\n Fees_storage.burn_origination_fees\n ~origin:Protocol_migration\n ctxt\n ~storage_limit:(Z.of_int64 Int64.max_int)\n ~payer:`Liquidity_baking_subsidies\n >>=? fun (ctxt, _, origination_updates) ->\n Fees_storage.burn_storage_fees\n ~origin:Protocol_migration\n ctxt\n ~storage_limit:(Z.of_int64 Int64.max_int)\n ~payer:`Liquidity_baking_subsidies\n size\n >>=? fun (ctxt, _, storage_updates) ->\n Token.transfer\n ~origin:Protocol_migration\n ctxt\n `Liquidity_baking_subsidies\n (`Contract address)\n balance\n >>=? fun (ctxt, transfer_updates) ->\n let balance_updates =\n origination_updates @ storage_updates @ transfer_updates\n in\n let result : Migration_repr.origination_result =\n {\n balance_updates;\n originated_contracts = [address_hash];\n storage_size = size;\n paid_storage_size_diff = size;\n }\n in\n return (ctxt, result)\n\nlet originate_test_fa12 ~typecheck ctxt admin =\n Contract_storage.fresh_contract_from_current_nonce ctxt\n >>?= fun (ctxt, fa12_address) ->\n let script =\n Script_repr.\n {\n code = Script_repr.lazy_expr Liquidity_baking_lqt.script;\n storage =\n test_fa12_init_storage (Signature.Public_key_hash.to_b58check admin);\n }\n in\n typecheck ctxt script >>=? fun (script, ctxt) ->\n originate ctxt fa12_address ~balance:(Tez_repr.of_mutez_exn 1_000_000L) script\n >|=? fun (ctxt, origination_result) ->\n (ctxt, fa12_address, [origination_result])\n\n(* hardcoded from lib_parameters *)\nlet first_bootstrap_account =\n Signature.Public_key.hash\n (Signature.Public_key.of_b58check_exn\n \"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav\")\n\nlet check_tzBTC ~typecheck current_level ctxt f =\n Contract_storage.exists ctxt (Contract_repr.Originated mainnet_tzBTC_address)\n >>= function\n | true ->\n (* If tzBTC exists, we're on mainnet and we use it as the token address in the CPMM. *)\n f ctxt mainnet_tzBTC_address []\n | false ->\n (* If the tzBTC contract does not exist, we originate a test FA1.2 contract using the same script as the LQT. This is so that we can test the contracts after performing the same protocol migration that will be done on mainnet.\n\n First, we check current level is below mainnet level roughly around 010 injection so we do not accidentally originate the test token contract on mainnet. *)\n if Compare.Int32.(current_level < 1_437_862l) then\n originate_test_fa12 ~typecheck ctxt first_bootstrap_account\n (* Token contract admin *)\n >>=? fun (ctxt, token_address, token_result) ->\n f ctxt token_address token_result\n else\n (* If we accidentally entered the tzBTC address incorrectly, but current level indicates this could be mainnet, we do not originate any contracts *)\n return (ctxt, [])\n\nlet init ctxt ~typecheck =\n (* We use a custom origination nonce because it is unset when stitching from 009 *)\n let nonce = Operation_hash.hash_string [\"Drip, drip, drip.\"] in\n let ctxt = Raw_context.init_origination_nonce ctxt nonce in\n Storage.Liquidity_baking.Toggle_ema.init ctxt 0l >>=? fun ctxt ->\n let current_level =\n Raw_level_repr.to_int32 (Level_storage.current ctxt).level\n in\n Contract_storage.fresh_contract_from_current_nonce ctxt\n >>?= fun (ctxt, cpmm_address) ->\n Contract_storage.fresh_contract_from_current_nonce ctxt\n >>?= fun (ctxt, lqt_address) ->\n Storage.Liquidity_baking.Cpmm_address.init ctxt cpmm_address >>=? fun ctxt ->\n check_tzBTC\n ~typecheck\n current_level\n ctxt\n (fun ctxt token_address token_result ->\n let cpmm_script =\n Script_repr.\n {\n code = Script_repr.lazy_expr Liquidity_baking_cpmm.script;\n storage =\n cpmm_init_storage\n ~token_address:(Contract_hash.to_b58check token_address)\n ~lqt_address:(Contract_hash.to_b58check lqt_address);\n }\n in\n typecheck ctxt cpmm_script >>=? fun (cpmm_script, ctxt) ->\n let lqt_script =\n Script_repr.\n {\n code = Script_repr.lazy_expr Liquidity_baking_lqt.script;\n storage = lqt_init_storage (Contract_hash.to_b58check cpmm_address);\n }\n in\n typecheck ctxt lqt_script >>=? fun (lqt_script, ctxt) ->\n originate\n ctxt\n cpmm_address\n ~balance:(Tez_repr.of_mutez_exn 100L)\n cpmm_script\n >>=? fun (ctxt, cpmm_result) ->\n originate ctxt lqt_address ~balance:Tez_repr.zero lqt_script\n >|=? fun (ctxt, lqt_result) ->\n (* Unsets the origination nonce, which is okay because this is called after other originations in stitching. *)\n let ctxt = Raw_context.unset_origination_nonce ctxt in\n (ctxt, [cpmm_result; lqt_result] @ token_result))\n" ;
} ;
{ name = "Sc_rollup_errors" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 TriliTech <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error +=\n | (* `Temporary *) Sc_rollup_disputed\n | (* `Temporary *) Sc_rollup_does_not_exist of Sc_rollup_repr.t\n | (* `Temporary *) Sc_rollup_no_conflict\n | (* `Temporary *) Sc_rollup_no_stakers\n | (* `Temporary *) Sc_rollup_not_staked\n | (* `Temporary *) Sc_rollup_not_staked_on_lcc_or_ancestor\n | (* `Temporary *) Sc_rollup_parent_not_lcc\n | (* `Temporary *) Sc_rollup_remove_lcc_or_ancestor\n | (* `Temporary *) Sc_rollup_staker_double_stake\n | (* `Temporary *) Sc_rollup_too_far_ahead\n | (* `Temporary *)\n Sc_rollup_commitment_from_future of {\n current_level : Raw_level_repr.t;\n inbox_level : Raw_level_repr.t;\n }\n | (* `Temporary *)\n Sc_rollup_commitment_too_recent of {\n current_level : Raw_level_repr.t;\n min_level : Raw_level_repr.t;\n }\n | (* `Temporary *)\n Sc_rollup_unknown_commitment of\n Sc_rollup_commitment_repr.Hash.t\n | (* `Temporary *) Sc_rollup_bad_inbox_level\n | (* `Temporary *) Sc_rollup_game_already_started\n | (* `Temporary *)\n Sc_rollup_max_number_of_parallel_games_reached of\n Signature.Public_key_hash.t\n | (* `Temporary *) Sc_rollup_wrong_turn\n | (* `Temporary *) Sc_rollup_no_game\n | (* `Temporary *)\n Sc_rollup_staker_in_game of\n [ `Refuter of Signature.public_key_hash\n | `Defender of Signature.public_key_hash\n | `Both of Signature.public_key_hash * Signature.public_key_hash ]\n | (* `Temporary *)\n Sc_rollup_timeout_level_not_reached of\n int32 * Signature.public_key_hash\n | (* `Temporary *)\n Sc_rollup_max_number_of_messages_reached_for_commitment_period\n | (* `Permanent *) Sc_rollup_add_zero_messages\n | (* `Temporary *) Sc_rollup_invalid_outbox_message_index\n | (* `Temporary *) Sc_rollup_outbox_level_expired\n | (* `Temporary *) Sc_rollup_outbox_message_already_applied\n | (* `Temporary *)\n Sc_rollup_staker_funds_too_low of {\n staker : Signature.public_key_hash;\n sc_rollup : Sc_rollup_repr.t;\n staker_balance : Tez_repr.t;\n min_expected_balance : Tez_repr.t;\n }\n | (* `Temporary *) Sc_rollup_bad_commitment_serialization\n | (* `Permanent *) Sc_rollup_address_generation\n | (* `Permanent *) Sc_rollup_zero_tick_commitment\n | (* `Permanent *) Sc_rollup_commitment_past_curfew\n | (* `Permanent *)\n Sc_rollup_not_valid_commitments_conflict of\n Sc_rollup_commitment_repr.Hash.t\n * Signature.public_key_hash\n * Sc_rollup_commitment_repr.Hash.t\n * Signature.public_key_hash\n | (* `Permanent *)\n Sc_rollup_wrong_staker_for_conflict_commitment of\n Signature.public_key_hash * Sc_rollup_commitment_repr.Hash.t\n | (* `Permanent *)\n Sc_rollup_invalid_commitment_to_cement of {\n valid_candidate : Sc_rollup_commitment_repr.Hash.t;\n invalid_candidate : Sc_rollup_commitment_repr.Hash.t;\n }\n | (* `Permanent *)\n Sc_rollup_commitment_too_old of {\n last_cemented_inbox_level : Raw_level_repr.t;\n commitment_inbox_level : Raw_level_repr.t;\n }\n\nlet () =\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_staker_in_game\"\n ~title:\"Staker is already playing a game\"\n ~description:\"Attempted to start a game where one staker is already busy\"\n ~pp:(fun ppf staker ->\n let busy ppf = function\n | `Refuter sc ->\n Format.fprintf\n ppf\n \"the refuter (%a) is\"\n Signature.Public_key_hash.pp\n sc\n | `Defender sc ->\n Format.fprintf\n ppf\n \"the defender (%a) is\"\n Signature.Public_key_hash.pp\n sc\n | `Both (refuter, defender) ->\n Format.fprintf\n ppf\n \"both the refuter (%a) and the defender (%a) are\"\n Signature.Public_key_hash.pp\n refuter\n Signature.Public_key_hash.pp\n defender\n in\n Format.fprintf\n ppf\n \"Attempted to start a game where %a already busy.\"\n busy\n staker)\n Data_encoding.(\n union\n [\n case\n (Tag 0)\n ~title:\"Refuter\"\n (obj1 (req \"refuter\" Signature.Public_key_hash.encoding))\n (function `Refuter sc -> Some sc | _ -> None)\n (fun sc -> `Refuter sc);\n case\n (Tag 1)\n ~title:\"Defender\"\n (obj1 (req \"defender\" Signature.Public_key_hash.encoding))\n (function `Defender sc -> Some sc | _ -> None)\n (fun sc -> `Defender sc);\n case\n (Tag 2)\n ~title:\"Both\"\n (obj2\n (req \"refuter\" Signature.Public_key_hash.encoding)\n (req \"defender\" Signature.Public_key_hash.encoding))\n (function\n | `Both (refuter, defender) -> Some (refuter, defender)\n | _ -> None)\n (fun (refuter, defender) -> `Both (refuter, defender));\n ])\n (function Sc_rollup_staker_in_game x -> Some x | _ -> None)\n (fun x -> Sc_rollup_staker_in_game x) ;\n let description = \"Attempt to timeout game too early\" in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_timeout_level_not_reached\"\n ~title:\"Attempt to timeout game too early\"\n ~description\n ~pp:(fun ppf (blocks_left, staker) ->\n Format.fprintf\n ppf\n \"%s. The player %a has %ld left blocks to play.\"\n description\n Signature.Public_key_hash.pp_short\n staker\n blocks_left)\n Data_encoding.(\n obj2\n (req \"level_timeout\" int32)\n (req \"staker\" Signature.Public_key_hash.encoding))\n (function\n | Sc_rollup_timeout_level_not_reached (blocks_left, staker) ->\n Some (blocks_left, staker)\n | _ -> None)\n (fun (blocks_left, staker) ->\n Sc_rollup_timeout_level_not_reached (blocks_left, staker)) ;\n let description =\n \"Refutation game already started, must play with is_opening_move = false.\"\n in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_game_already_started\"\n ~title:\"Refutation game already started\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.unit\n (function Sc_rollup_game_already_started -> Some () | _ -> None)\n (fun () -> Sc_rollup_game_already_started) ;\n let description = \"Refutation game does not exist\" in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_no_game\"\n ~title:\"Refutation game does not exist\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.unit\n (function Sc_rollup_no_game -> Some () | _ -> None)\n (fun () -> Sc_rollup_no_game) ;\n let description = \"Attempt to play move but not staker's turn\" in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_wrong_turn\"\n ~title:\"Attempt to play move but not staker's turn\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.unit\n (function Sc_rollup_wrong_turn -> Some () | _ -> None)\n (fun () -> Sc_rollup_wrong_turn) ;\n let description =\n \"Maximum number of messages reached for commitment period\"\n in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_max_number_of_messages_reached_for_commitment_period\"\n ~title:\"Maximum number of messages reached for commitment period\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.unit\n (function\n | Sc_rollup_max_number_of_messages_reached_for_commitment_period ->\n Some ()\n | _ -> None)\n (fun () -> Sc_rollup_max_number_of_messages_reached_for_commitment_period) ;\n let description = \"Tried to add zero messages to a smart rollup\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_add_zero_messages\"\n ~title:description\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.unit\n (function Sc_rollup_add_zero_messages -> Some () | _ -> None)\n (fun () -> Sc_rollup_add_zero_messages) ;\n let description = \"Attempted to cement a disputed commitment.\" in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_commitment_disputed\"\n ~title:\"Commitment disputed\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Sc_rollup_disputed -> Some () | _ -> None)\n (fun () -> Sc_rollup_disputed) ;\n let description =\n \"Attempted to use a smart rollup that has not been originated.\"\n in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_does_not_exist\"\n ~title:\"Smart rollup does not exist\"\n ~description\n ~pp:(fun ppf x ->\n Format.fprintf ppf \"Smart rollup %a does not exist\" Sc_rollup_repr.pp x)\n Data_encoding.(obj1 (req \"rollup\" Sc_rollup_repr.encoding))\n (function Sc_rollup_does_not_exist x -> Some x | _ -> None)\n (fun x -> Sc_rollup_does_not_exist x) ;\n let description = \"No conflict.\" in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_no_conflict\"\n ~title:\"No conflict\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Sc_rollup_no_conflict -> Some () | _ -> None)\n (fun () -> Sc_rollup_no_conflict) ;\n let description = \"No stakers for the targeted smart rollup.\" in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_no_stakers\"\n ~title:\"No stakers\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Sc_rollup_no_stakers -> Some () | _ -> None)\n (fun () -> Sc_rollup_no_stakers) ;\n let description =\n \"This implicit account is not a staker of this smart rollup.\"\n in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_not_staked\"\n ~title:\"Unknown staker\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Sc_rollup_not_staked -> Some () | _ -> None)\n (fun () -> Sc_rollup_not_staked) ;\n let description =\n \"Attempted to withdraw while not staked on the last cemented commitment or \\\n its ancestor.\"\n in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_not_staked_on_lcc_or_ancestor\"\n ~title:\"Smart rollup not staked on LCC or its ancestor\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Sc_rollup_not_staked_on_lcc_or_ancestor -> Some () | _ -> None)\n (fun () -> Sc_rollup_not_staked_on_lcc_or_ancestor) ;\n let description = \"Parent is not the last cemented commitment.\" in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_parent_not_lcc\"\n ~title:\"Parent is not the last cemented commitment\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Sc_rollup_parent_not_lcc -> Some () | _ -> None)\n (fun () -> Sc_rollup_parent_not_lcc) ;\n let description = \"Can not remove a staker committed on cemented.\" in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_remove_lcc_or_ancestor\"\n ~title:\"Can not remove a staker\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Sc_rollup_remove_lcc_or_ancestor -> Some () | _ -> None)\n (fun () -> Sc_rollup_remove_lcc_or_ancestor) ;\n let description = \"Staker tried to double stake.\" in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_staker_double_stake\"\n ~title:description\n ~description\n ~pp:(fun ppf () ->\n Format.pp_print_string\n ppf\n \"The staker tried to double stake, that is, it tried to publish a \\\n commitment for an inbox level where it already published another \\\n conflicting commitment. The staker is not allowed to changed its \\\n mind.\")\n Data_encoding.empty\n (function Sc_rollup_staker_double_stake -> Some () | _ -> None)\n (fun () -> Sc_rollup_staker_double_stake) ;\n let description =\n \"Commitment is too far ahead of the last cemented commitment.\"\n in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_too_far_ahead\"\n ~title:\"Commitment too far ahead\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Sc_rollup_too_far_ahead -> Some () | _ -> None)\n (fun () -> Sc_rollup_too_far_ahead) ;\n let description =\n \"Attempted to cement a commitment before its refutation deadline.\"\n in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_commitment_too_recent\"\n ~title:\"Commitment too recent\"\n ~description\n ~pp:(fun ppf (current_level, min_level) ->\n Format.fprintf\n ppf\n \"%s@ Current level: %a,@ minimal level: %a\"\n description\n Raw_level_repr.pp\n current_level\n Raw_level_repr.pp\n min_level)\n Data_encoding.(\n obj2\n (req \"current_level\" Raw_level_repr.encoding)\n (req \"min_level\" Raw_level_repr.encoding))\n (function\n | Sc_rollup_commitment_too_recent {current_level; min_level} ->\n Some (current_level, min_level)\n | _ -> None)\n (fun (current_level, min_level) ->\n Sc_rollup_commitment_too_recent {current_level; min_level}) ;\n let description = \"Unknown commitment.\" in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_unknown_commitment\"\n ~title:\"Unknown commitment\"\n ~description\n ~pp:(fun ppf x ->\n Format.fprintf\n ppf\n \"Commitment %a does not exist\"\n Sc_rollup_commitment_repr.Hash.pp\n x)\n Data_encoding.(\n obj1 (req \"commitment\" Sc_rollup_commitment_repr.Hash.encoding))\n (function Sc_rollup_unknown_commitment x -> Some x | _ -> None)\n (fun x -> Sc_rollup_unknown_commitment x) ;\n let description = \"Attempted to commit to a bad inbox level.\" in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_bad_inbox_level\"\n ~title:\"Committing to a bad inbox level\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Sc_rollup_bad_inbox_level -> Some () | _ -> None)\n (fun () -> Sc_rollup_bad_inbox_level) ;\n let description = \"Invalid rollup outbox message index\" in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_invalid_outbox_message_index\"\n ~title:\"Invalid rollup outbox message index\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Sc_rollup_invalid_outbox_message_index -> Some () | _ -> None)\n (fun () -> Sc_rollup_invalid_outbox_message_index) ;\n let description = \"Outbox level expired\" in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_outbox_level_expired\"\n ~title:description\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Sc_rollup_outbox_level_expired -> Some () | _ -> None)\n (fun () -> Sc_rollup_outbox_level_expired) ;\n let description = \"Outbox message already applied\" in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_outbox_message_already_applied\"\n ~title:description\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Sc_rollup_outbox_message_already_applied -> Some () | _ -> None)\n (fun () -> Sc_rollup_outbox_message_already_applied) ;\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_staker_funds_too_low\"\n ~title:\"Staker does not have enough funds to make a deposit\"\n ~description:\n \"Staker doesn't have enough funds to make a smart rollup deposit.\"\n ~pp:(fun ppf (staker, sc_rollup, staker_balance, min_expected_balance) ->\n Format.fprintf\n ppf\n \"Staker (%a) doesn't have enough funds to make the deposit for smart \\\n rollup (%a). Staker's balance is %a while a balance of at least %a is \\\n required.\"\n Signature.Public_key_hash.pp\n staker\n Sc_rollup_repr.pp\n sc_rollup\n Tez_repr.pp\n staker_balance\n Tez_repr.pp\n min_expected_balance)\n Data_encoding.(\n obj4\n (req \"staker\" Signature.Public_key_hash.encoding)\n (req \"smart_rollup\" Sc_rollup_repr.encoding)\n (req \"staker_balance\" Tez_repr.encoding)\n (req \"min_expected_balance\" Tez_repr.encoding))\n (function\n | Sc_rollup_staker_funds_too_low\n {staker; sc_rollup; staker_balance; min_expected_balance} ->\n Some (staker, sc_rollup, staker_balance, min_expected_balance)\n | _ -> None)\n (fun (staker, sc_rollup, staker_balance, min_expected_balance) ->\n Sc_rollup_staker_funds_too_low\n {staker; sc_rollup; staker_balance; min_expected_balance}) ;\n let description = \"Could not serialize commitment.\" in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_bad_commitment_serialization\"\n ~title:\"Could not serialize commitment.\"\n ~description:\"Unable to hash the commitment serialization.\"\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Sc_rollup_bad_commitment_serialization -> Some () | _ -> None)\n (fun () -> Sc_rollup_bad_commitment_serialization) ;\n let description =\n \"Commitment inbox level is greater or equal than current level\"\n in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_commitment_from_future\"\n ~title:\"Commitment from future\"\n ~description\n ~pp:(fun ppf (current_level, inbox_level) ->\n Format.fprintf\n ppf\n \"%s@ Current level: %a,@ commitment inbox level: %a\"\n description\n Raw_level_repr.pp\n current_level\n Raw_level_repr.pp\n inbox_level)\n Data_encoding.(\n obj2\n (req \"current_level\" Raw_level_repr.encoding)\n (req \"inbox_level\" Raw_level_repr.encoding))\n (function\n | Sc_rollup_commitment_from_future {current_level; inbox_level} ->\n Some (current_level, inbox_level)\n | _ -> None)\n (fun (current_level, inbox_level) ->\n Sc_rollup_commitment_from_future {current_level; inbox_level}) ;\n let description = \"Commitment is past the curfew for this level.\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_commitment_past_curfew\"\n ~title:\"Commitment past curfew.\"\n ~description:\n \"A commitment exists for this inbox level for longer than the curfew \\\n period.\"\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Sc_rollup_commitment_past_curfew -> Some () | _ -> None)\n (fun () -> Sc_rollup_commitment_past_curfew) ;\n let description = \"Error while generating a smart rollup address\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_address_generation\"\n ~title:description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n ~description\n Data_encoding.empty\n (function Sc_rollup_address_generation -> Some () | _ -> None)\n (fun () -> Sc_rollup_address_generation) ;\n let description = \"Tried to publish a 0 tick commitment\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_zero_tick_commitment\"\n ~title:description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n ~description\n Data_encoding.empty\n (function Sc_rollup_zero_tick_commitment -> Some () | _ -> None)\n (fun () -> Sc_rollup_zero_tick_commitment) ;\n let description = \"Maximal number of parallel games reached\" in\n register_error_kind\n `Temporary\n ~id:\"smart_rollup_maximal_number_of_parallel_games_reached\"\n ~title:description\n ~pp:(fun ppf staker ->\n Format.fprintf\n ppf\n \"%a has reached the limit for number of parallel games\"\n Signature.Public_key_hash.pp\n staker)\n ~description\n Data_encoding.(obj1 (req \"staker\" Signature.Public_key_hash.encoding))\n (function\n | Sc_rollup_max_number_of_parallel_games_reached staker -> Some staker\n | _ -> None)\n (fun staker -> Sc_rollup_max_number_of_parallel_games_reached staker) ;\n let description = \"Conflicting commitments do not have a common ancestor\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_not_valid_commitments_conflict\"\n ~title:description\n ~pp:(fun ppf (c1, s1, c2, s2) ->\n Format.fprintf\n ppf\n \"The two commitments %a, staked by %a, and %a, staked by %a, does not \\\n have a common predecessor. Two commitments are in conflict when there \\\n direct predecessor is the same.\"\n Sc_rollup_commitment_repr.Hash.pp\n c1\n Signature.Public_key_hash.pp_short\n s1\n Sc_rollup_commitment_repr.Hash.pp\n c2\n Signature.Public_key_hash.pp_short\n s2)\n ~description\n Data_encoding.(\n obj4\n (req \"commitment\" Sc_rollup_commitment_repr.Hash.encoding)\n (req \"player\" Signature.Public_key_hash.encoding)\n (req \"opponent_commitment\" Sc_rollup_commitment_repr.Hash.encoding)\n (req \"opponent\" Signature.Public_key_hash.encoding))\n (function\n | Sc_rollup_not_valid_commitments_conflict (c1, s1, c2, s2) ->\n Some (c1, s1, c2, s2)\n | _ -> None)\n (fun (c1, s1, c2, s2) ->\n Sc_rollup_not_valid_commitments_conflict (c1, s1, c2, s2)) ;\n let description = \"Given commitment is not staked by given staker\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_wrong_staker_for_conflict_commitment\"\n ~title:description\n ~pp:(fun ppf (staker, commitment) ->\n Format.fprintf\n ppf\n \"The staker %a has not staked commitment %a\"\n Signature.Public_key_hash.pp\n staker\n Sc_rollup_commitment_repr.Hash.pp\n commitment)\n ~description\n Data_encoding.(\n obj2\n (req \"player\" Signature.Public_key_hash.encoding)\n (req \"commitment\" Sc_rollup_commitment_repr.Hash.encoding))\n (function\n | Sc_rollup_wrong_staker_for_conflict_commitment (staker, commitment) ->\n Some (staker, commitment)\n | _ -> None)\n (fun (staker, commitment) ->\n Sc_rollup_wrong_staker_for_conflict_commitment (staker, commitment)) ;\n let description = \"Given commitment cannot be cemented\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_invalid_commitment_to_cement\"\n ~title:description\n ~pp:(fun ppf (valid_candidate, invalid_candidate) ->\n Format.fprintf\n ppf\n \"The commitment %a cannot be cemented. %a is a valid candidate to \\\n cementation, but %a is not.\"\n Sc_rollup_commitment_repr.Hash.pp\n invalid_candidate\n Sc_rollup_commitment_repr.Hash.pp\n valid_candidate\n Sc_rollup_commitment_repr.Hash.pp\n invalid_candidate)\n ~description\n Data_encoding.(\n obj2\n (req \"valid_candidate\" Sc_rollup_commitment_repr.Hash.encoding)\n (req \"invalid_candidate\" Sc_rollup_commitment_repr.Hash.encoding))\n (function\n | Sc_rollup_invalid_commitment_to_cement\n {valid_candidate; invalid_candidate} ->\n Some (valid_candidate, invalid_candidate)\n | _ -> None)\n (fun (valid_candidate, invalid_candidate) ->\n Sc_rollup_invalid_commitment_to_cement\n {valid_candidate; invalid_candidate}) ;\n\n let description = \"Published commitment is too old\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_commitment_too_old\"\n ~title:description\n ~pp:(fun ppf (last_cemented_inbox_level, commitment_inbox_level) ->\n Format.fprintf\n ppf\n \"The published commitment is for the inbox level %a, the last cemented \\\n commitment inbox level is %a. You cannot publish a commitment behind \\\n the last cemented commitment.\"\n Raw_level_repr.pp\n last_cemented_inbox_level\n Raw_level_repr.pp\n commitment_inbox_level)\n ~description\n Data_encoding.(\n obj2\n (req \"last_cemented_inbox_level\" Raw_level_repr.encoding)\n (req \"commitment_inbox_level\" Raw_level_repr.encoding))\n (function\n | Sc_rollup_commitment_too_old\n {last_cemented_inbox_level; commitment_inbox_level} ->\n Some (last_cemented_inbox_level, commitment_inbox_level)\n | _ -> None)\n (fun (last_cemented_inbox_level, commitment_inbox_level) ->\n Sc_rollup_commitment_too_old\n {last_cemented_inbox_level; commitment_inbox_level})\n" ;
} ;
{ name = "Sc_rollup_inbox_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 TriliTech <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** [get_inbox context] returns the current state of the inbox,\n if it exists. *)\nval get_inbox :\n Raw_context.t -> (Sc_rollup_inbox_repr.t * Raw_context.t) tzresult Lwt.t\n\n(** [add_external_messages context messages] adds [messages] to the smart\n rollups internal inbox level witness. *)\nval add_external_messages :\n Raw_context.t -> string list -> Raw_context.t tzresult Lwt.t\n\n(** [add_deposit ~payload ~sender ~source ~destination ctxt] adds the\n internal deposit message of [payload], [sender], and [source] to\n the smart-contract rollups' inbox.\n\n See [add_external_messages] for returned values and failures.\n*)\nval add_deposit :\n Raw_context.t ->\n payload:Script_repr.expr ->\n sender:Contract_hash.t ->\n source:Signature.public_key_hash ->\n destination:Sc_rollup_repr.Address.t ->\n Raw_context.t tzresult Lwt.t\n\n(** Initialize the inbox in the storage at protocol initialization. *)\nval init_inbox :\n predecessor:Block_hash.t -> Raw_context.t -> Raw_context.t Lwt.t\n\n(** Adds the [Info_per_level] in the in-memory inbox level witness. *)\nval add_info_per_level :\n predecessor:Block_hash.t -> Raw_context.t -> Raw_context.t Lwt.t\n\n(** [finalize_inbox_level ctxt] ends the internal representation for the block.\n*)\nval finalize_inbox_level : Raw_context.t -> Raw_context.t Lwt.t\n\n(**/**)\n\nmodule Internal_for_tests : sig\n (** Push a [Start_of_level] internal inbox message in the inbox. *)\n val add_start_of_level : Raw_context.t -> Raw_context.t tzresult Lwt.t\n\n (** Push a [End_of_level] internal inbox message in the inbox. *)\n val add_end_of_level : Raw_context.t -> Raw_context.t tzresult Lwt.t\n\n (** Push a [Info_per_level] internal inbox message in the inbox. *)\n val add_info_per_level :\n Raw_context.t -> Time.t -> Block_hash.t -> Raw_context.t tzresult Lwt.t\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 TriliTech <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule Store = Storage.Sc_rollup\n\nlet get_inbox ctxt =\n let open Lwt_result_syntax in\n let* inbox = Store.Inbox.get ctxt in\n return (inbox, ctxt)\n\nlet add_messages ctxt messages =\n let open Lwt_result_syntax in\n let open Raw_context in\n (* TODO: https://gitlab.com/tezos/tezos/-/issues/3292\n\n The carbonation needs to be activated again with the new internal inbox's\n design, i.e. the skip list.\n *)\n let current_messages = Sc_rollup_in_memory_inbox.current_messages ctxt in\n let*? ctxt =\n List.fold_left_e\n (fun ctxt (message : Sc_rollup_inbox_message_repr.serialized) ->\n let msg_len = String.length (message :> string) in\n (* The average cost of adding a message with a\n [current_index] from [0] to [1_000_000] is reached after [100_000]\n messages.\n If we use the real index, the simulations of [Sc_rollup_add_messages]\n are always performed on an empty skip list.\n *)\n let cost =\n Sc_rollup_costs.cost_add_message\n ~current_index:Z.(of_int 100_000)\n ~msg_len\n in\n Raw_context.consume_gas ctxt cost)\n ctxt\n messages\n in\n (*\n Notice that the protocol is forgetful: it throws away the inbox\n history. On the contrary, the history is stored by the rollup\n node to produce inclusion proofs when needed.\n *)\n let*? current_messages =\n Sc_rollup_inbox_repr.add_messages_no_history messages current_messages\n in\n let ctxt =\n Sc_rollup_in_memory_inbox.set_current_messages ctxt current_messages\n in\n return ctxt\n\nlet serialize_external_messages ctxt external_messages =\n let open Sc_rollup_inbox_message_repr in\n List.fold_left_map_e\n (fun ctxt message ->\n let open Result_syntax in\n (* Pay gas for serializing an external message. *)\n let* ctxt =\n let bytes_len = String.length message in\n Raw_context.consume_gas\n ctxt\n (Sc_rollup_costs.cost_serialize_external_inbox_message ~bytes_len)\n in\n let* serialized_message = serialize @@ External message in\n return (ctxt, serialized_message))\n ctxt\n external_messages\n\nlet serialize_internal_message ctxt internal_message =\n let open Result_syntax in\n (* Pay gas for serializing an internal message. *)\n let* ctxt =\n Raw_context.consume_gas\n ctxt\n (Sc_rollup_costs.cost_serialize_internal_inbox_message internal_message)\n in\n let* message =\n Sc_rollup_inbox_message_repr.(serialize @@ Internal internal_message)\n in\n return (message, ctxt)\n\nlet add_external_messages ctxt external_messages =\n let open Lwt_result_syntax in\n let*? ctxt, messages = serialize_external_messages ctxt external_messages in\n add_messages ctxt messages\n\nlet add_internal_message ctxt internal_message =\n let open Lwt_result_syntax in\n let*? message, ctxt = serialize_internal_message ctxt internal_message in\n add_messages ctxt [message]\n\nlet add_deposit ctxt ~payload ~sender ~source ~destination =\n let internal_message : Sc_rollup_inbox_message_repr.internal_inbox_message =\n Transfer {destination; payload; sender; source}\n in\n add_internal_message ctxt internal_message\n\nlet finalize_inbox_level ctxt =\n let open Lwt_syntax in\n let* res =\n let open Lwt_result_syntax in\n let* inbox, ctxt = get_inbox ctxt in\n let witness = Raw_context.Sc_rollup_in_memory_inbox.current_messages ctxt in\n let*? inbox =\n Sc_rollup_inbox_repr.finalize_inbox_level_no_history inbox witness\n in\n let* ctxt = Store.Inbox.update ctxt inbox in\n return ctxt\n in\n match res with\n | Ok ctxt -> return ctxt\n | Error err ->\n (* As a protection, we backtrack the [ctxt] if finalizing the inbox level\n failed. This way, we cannot make [finalize_block] fail. *)\n Logging.(\n log\n Fatal\n \"Finalizing inbox level failed because of %a, the context is \\\n backtracked. Smart rollups inbox failed to finalize this block, \\\n this behavior is undefined and its consequence is unexplored.\"\n pp_trace\n err) ;\n return ctxt\n\nlet add_info_per_level ~predecessor ctxt =\n let open Lwt_syntax in\n let* res =\n let open Lwt_result_syntax in\n let predecessor_timestamp = Raw_context.predecessor_timestamp ctxt in\n let witness = Raw_context.Sc_rollup_in_memory_inbox.current_messages ctxt in\n let*? witness =\n Sc_rollup_inbox_repr.add_info_per_level_no_history\n ~predecessor_timestamp\n ~predecessor\n witness\n in\n let ctxt =\n Raw_context.Sc_rollup_in_memory_inbox.set_current_messages ctxt witness\n in\n return ctxt\n in\n match res with\n | Ok ctxt -> return ctxt\n | Error err ->\n (* As a protection, we backtrack the [ctxt] if adding the info per level\n failed. This way, we cannot make [begin_application],\n [begin_partial_application] and [begin_full_construction] fail. *)\n Logging.(\n log\n Fatal\n \"Adding [Info_per_level] failed because of %a, the context is \\\n backtracked. Smart rollups inbox failed to finalize this block, \\\n this behavior is undefined and its consequence is unexplored.\"\n pp_trace\n err) ;\n return ctxt\n\nlet init_inbox ~predecessor ctxt =\n let open Lwt_syntax in\n let* res =\n let open Lwt_result_syntax in\n let ({level; _} : Level_repr.t) = Raw_context.current_level ctxt in\n let predecessor_timestamp = Raw_context.predecessor_timestamp ctxt in\n let*? inbox =\n Sc_rollup_inbox_repr.genesis ~predecessor_timestamp ~predecessor level\n in\n let* ctxt = Store.Inbox.init ctxt inbox in\n return ctxt\n in\n match res with\n | Ok ctxt -> return ctxt\n | Error err ->\n (* As a protection, we backtrack the [ctxt] if initializing the inbox\n failed. This way, we cannot make [prepare_first_block] fail. *)\n Logging.(\n log\n Fatal\n \"Initializing inbox failed because of %a, the context is \\\n backtracked. Smart rollups inbox failed, this behavior is undefined \\\n and its consequence is unexplored.\"\n pp_trace\n err) ;\n return ctxt\n\nmodule Internal_for_tests = struct\n let add_start_of_level ctxt =\n add_internal_message ctxt Sc_rollup_inbox_message_repr.Start_of_level\n\n let add_end_of_level ctxt =\n add_internal_message ctxt Sc_rollup_inbox_message_repr.End_of_level\n\n let add_info_per_level ctxt predecessor_timestamp predecessor =\n add_internal_message\n ctxt\n (Sc_rollup_inbox_message_repr.Info_per_level\n {predecessor_timestamp; predecessor})\nend\n" ;
} ;
{ name = "Legacy_script_patches" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t = {\n addresses : string list;\n hash : Script_expr_hash.t;\n patched_code : Michelson_v1_primitives.prim Micheline.canonical;\n}\n\nlet script_hash {hash; _} = hash\n\nlet code {patched_code; _} = patched_code\n\nlet bin_expr_exn hex =\n match\n Option.bind\n (Hex.to_bytes @@ `Hex hex)\n (fun bytes ->\n Data_encoding.Binary.of_bytes_opt Script_repr.expr_encoding bytes)\n with\n | Some expr -> expr\n | None -> raise (Failure \"Decoding script failed.\")\n\nlet patches = []\n\nlet addresses_to_patch =\n List.concat_map\n (fun {hash; patched_code; addresses} ->\n List.map (fun addr -> (addr, hash, patched_code)) addresses)\n patches\n" ;
} ;
{ name = "Init_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020-2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Functions to setup storage. Used by [Alpha_context.prepare].\n\n If you have defined a new type of storage, you should add relevant\n setups here.\n *)\n\n(* This is the genesis protocol: initialise the state *)\nval prepare_first_block :\n Chain_id.t ->\n Context.t ->\n typecheck:\n (Raw_context.t ->\n Script_repr.t ->\n ((Script_repr.t * Lazy_storage_diff.diffs option) * Raw_context.t)\n Error_monad.tzresult\n Lwt.t) ->\n level:int32 ->\n timestamp:Time.t ->\n predecessor:Block_hash.t ->\n (Raw_context.t, Error_monad.error Error_monad.trace) Pervasives.result Lwt.t\n\nval prepare :\n Context.t ->\n level:Int32.t ->\n predecessor_timestamp:Time.t ->\n timestamp:Time.t ->\n (Raw_context.t\n * Receipt_repr.balance_updates\n * Migration_repr.origination_result list)\n Error_monad.tzresult\n Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2019-2020 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2021 DaiLambda, Inc. <contact@dailambda.jp> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(*\n To add invoices, you can use a helper function like this one:\n\n(** Invoice a contract at a given address with a given amount. Returns the\n updated context and a balance update receipt (singleton list). The address\n must be a valid base58 hash, otherwise this is no-op and returns an empty\n receipts list.\n\n Do not fail if something goes wrong.\n*)\n\nlet invoice_contract ctxt ~address ~amount_mutez =\n match Tez_repr.of_mutez amount_mutez with\n | None -> Lwt.return (ctxt, [])\n | Some amount -> (\n ( Contract_repr.of_b58check address >>?= fun recipient ->\n Token.transfer\n ~origin:Protocol_migration\n ctxt\n `Invoice\n (`Contract recipient)\n amount )\n >|= function\n | Ok res -> res\n | Error _ -> (ctxt, []))\n*)\n\n(*\n To patch code of legacy contracts you can add a helper function here and call\n it at the end of prepare_first_block.\n\n See !3730 for an example.\n*)\n\nlet patch_script (address, hash, patched_code) ctxt =\n Contract_repr.of_b58check address >>?= fun contract ->\n Storage.Contract.Code.find ctxt contract >>=? fun (ctxt, code_opt) ->\n Logging.log Notice \"Patching %s... \" address ;\n match code_opt with\n | Some old_code ->\n let old_bin = Data_encoding.force_bytes old_code in\n let old_hash = Script_expr_hash.hash_bytes [old_bin] in\n if Script_expr_hash.equal old_hash hash then (\n let new_code = Script_repr.lazy_expr patched_code in\n Storage.Contract.Code.update ctxt contract new_code\n >>=? fun (ctxt, size_diff) ->\n Logging.log Notice \"Contract %s successfully patched\" address ;\n let size_diff = Z.of_int size_diff in\n Storage.Contract.Used_storage_space.get ctxt contract\n >>=? fun prev_size ->\n let new_size = Z.add prev_size size_diff in\n Storage.Contract.Used_storage_space.update ctxt contract new_size\n >>=? fun ctxt ->\n if Z.(gt size_diff zero) then\n Storage.Contract.Paid_storage_space.get ctxt contract\n >>=? fun prev_paid_size ->\n let paid_size = Z.add prev_paid_size size_diff in\n Storage.Contract.Paid_storage_space.update ctxt contract paid_size\n else return ctxt)\n else (\n Logging.log\n Error\n \"Patching %s was skipped because its script does not have the \\\n expected hash (expected: %a, found: %a)\"\n address\n Script_expr_hash.pp\n hash\n Script_expr_hash.pp\n old_hash ;\n return ctxt)\n | None ->\n Logging.log\n Error\n \"Patching %s was skipped because no script was found for it in the \\\n context.\"\n address ;\n return ctxt\n\nlet prepare_first_block _chain_id ctxt ~typecheck ~level ~timestamp ~predecessor\n =\n Raw_context.prepare_first_block ~level ~timestamp ctxt\n >>=? fun (previous_protocol, ctxt) ->\n let parametric = Raw_context.constants ctxt in\n ( Raw_context.Cache.set_cache_layout\n ctxt\n (Constants_repr.cache_layout parametric)\n >|= fun ctxt -> Raw_context.Cache.clear ctxt )\n >>= fun ctxt ->\n (match previous_protocol with\n | Genesis param ->\n (* This is the genesis protocol: initialise the state *)\n Raw_level_repr.of_int32 level >>?= fun level ->\n Storage.Tenderbake.First_level_of_protocol.init ctxt level\n >>=? fun ctxt ->\n Storage.Block_round.init ctxt Round_repr.zero >>=? fun ctxt ->\n let init_commitment (ctxt, balance_updates)\n Commitment_repr.{blinded_public_key_hash; amount} =\n Token.transfer\n ctxt\n `Initial_commitments\n (`Collected_commitments blinded_public_key_hash)\n amount\n >>=? fun (ctxt, new_balance_updates) ->\n return (ctxt, new_balance_updates @ balance_updates)\n in\n List.fold_left_es init_commitment (ctxt, []) param.commitments\n >>=? fun (ctxt, commitments_balance_updates) ->\n Storage.Stake.Last_snapshot.init ctxt 0 >>=? fun ctxt ->\n Seed_storage.init ?initial_seed:param.constants.initial_seed ctxt\n >>=? fun ctxt ->\n Contract_storage.init ctxt >>=? fun ctxt ->\n Bootstrap_storage.init\n ctxt\n ~typecheck\n ?no_reward_cycles:param.no_reward_cycles\n param.bootstrap_accounts\n param.bootstrap_contracts\n >>=? fun (ctxt, bootstrap_balance_updates) ->\n Delegate_cycles.init_first_cycles ctxt ~origin:Protocol_migration\n >>=? fun (ctxt, deposits_balance_updates) ->\n Vote_storage.init\n ctxt\n ~start_position:(Level_storage.current ctxt).level_position\n >>=? fun ctxt ->\n Vote_storage.update_listings ctxt >>=? fun ctxt ->\n (* Must be called after other originations since it unsets the origination nonce. *)\n Liquidity_baking_migration.init ctxt ~typecheck\n >>=? fun (ctxt, operation_results) ->\n Storage.Pending_migration.Operation_results.init ctxt operation_results\n >>=? fun ctxt ->\n Sc_rollup_inbox_storage.init_inbox ~predecessor ctxt >>= fun ctxt ->\n return\n ( ctxt,\n commitments_balance_updates @ bootstrap_balance_updates\n @ deposits_balance_updates )\n | Lima_015\n (* Please update [next_protocol] and [previous_protocol] in\n [tezt/lib_tezos/protocol.ml] when you update this value. *) ->\n (* TODO (#2704): possibly handle endorsements for migration block (in bakers);\n if that is done, do not set Storage.Tenderbake.First_level_of_protocol. *)\n Raw_level_repr.of_int32 level >>?= fun level ->\n Storage.Tenderbake.First_level_of_protocol.update ctxt level\n >>=? fun ctxt ->\n Sc_rollup_inbox_storage.init_inbox ~predecessor ctxt >>= fun ctxt ->\n return (ctxt, []))\n >>=? fun (ctxt, balance_updates) ->\n List.fold_right_es patch_script Legacy_script_patches.addresses_to_patch ctxt\n >>=? fun ctxt ->\n Receipt_repr.group_balance_updates balance_updates >>?= fun balance_updates ->\n Storage.Pending_migration.Balance_updates.add ctxt balance_updates\n >>= fun ctxt -> return ctxt\n\nlet prepare ctxt ~level ~predecessor_timestamp ~timestamp =\n Raw_context.prepare ~level ~predecessor_timestamp ~timestamp ctxt\n >>=? fun ctxt -> Storage.Pending_migration.remove ctxt\n" ;
} ;
{ name = "Sapling_validator" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2019-2020 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(* Check that each nullifier is not already present in the state and add it.\n Important to avoid spending the same input twice in a transaction. *)\nlet rec check_and_update_nullifiers ctxt state inputs =\n match inputs with\n | [] -> return (ctxt, Some state)\n | input :: inputs -> (\n Sapling_storage.nullifiers_mem ctxt state Sapling.UTXO.(input.nf)\n >>=? function\n | ctxt, true -> return (ctxt, None)\n | ctxt, false ->\n let state =\n Sapling_storage.nullifiers_add state Sapling.UTXO.(input.nf)\n in\n check_and_update_nullifiers ctxt state inputs)\n\nlet verify_update :\n Raw_context.t ->\n Sapling_storage.state ->\n Sapling_repr.transaction ->\n string ->\n (Raw_context.t * (Int64.t * Sapling_storage.state) option) tzresult Lwt.t =\n fun ctxt state transaction key ->\n (* Check the transaction *)\n (* To avoid overflowing the balance, the number of inputs and outputs must be\n bounded.\n Ciphertexts' memo_size must match the state's memo_size.\n These constraints are already enforced at the encoding level. *)\n assert (Compare.Int.(List.compare_length_with transaction.inputs 5208 <= 0)) ;\n assert (Compare.Int.(List.compare_length_with transaction.outputs 2019 <= 0)) ;\n let pass =\n List.for_all\n (fun output ->\n Compare.Int.(\n Sapling.Ciphertext.get_memo_size Sapling.UTXO.(output.ciphertext)\n = state.memo_size))\n transaction.outputs\n in\n if not pass then return (ctxt, None)\n else\n (* Check the root is a recent state *)\n Sapling_storage.root_mem ctxt state transaction.root >>=? fun pass ->\n if not pass then return (ctxt, None)\n else\n check_and_update_nullifiers ctxt state transaction.inputs >|=? function\n | ctxt, None -> (ctxt, None)\n | ctxt, Some state ->\n Sapling.Verification.with_verification_ctx (fun vctx ->\n let pass =\n (* Check all the output ZK proofs *)\n List.for_all\n (fun output -> Sapling.Verification.check_output vctx output)\n transaction.outputs\n in\n if not pass then (ctxt, None)\n else\n let pass =\n (* Check all the input Zk proofs and signatures *)\n List.for_all\n (fun input ->\n Sapling.Verification.check_spend\n vctx\n input\n transaction.root\n key)\n transaction.inputs\n in\n if not pass then (ctxt, None)\n else\n let pass =\n (* Check the signature and balance of the whole transaction *)\n Sapling.Verification.final_check vctx transaction key\n in\n if not pass then (ctxt, None)\n else\n (* update tree *)\n let list_to_add =\n List.map\n (fun output ->\n Sapling.UTXO.(output.cm, output.ciphertext))\n transaction.outputs\n in\n let state = Sapling_storage.add state list_to_add in\n (ctxt, Some (transaction.balance, state)))\n" ;
} ;
{ name = "Global_constants_costs" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Costs function for the global table of constants. *)\n\n(** Cost of calling [Global_constats_storage.expr_to_address_in_context]. *)\nval expr_to_address_in_context_cost : bytes -> Gas_limit_repr.cost\n\n(** Step costs for [Global_constats_storage.expand_node]. *)\nval expand_constants_branch_cost : Gas_limit_repr.cost\n\nval expand_no_constants_branch_cost : Script_repr.node -> Gas_limit_repr.cost\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule S = Saturation_repr\n\nlet log2 x = S.safe_int (1 + S.numbits x)\n\nlet ( + ) = S.add\n\nlet ( lsr ) = S.shift_right\n\n(* Approximating 200 + 1.266960 * number of bytes *)\nlet expr_to_address_in_context_cost bytes =\n let v0 = Bytes.length bytes |> S.safe_int in\n S.safe_int 200 + (v0 + (v0 lsr 2)) |> Gas_limit_repr.atomic_step_cost\n\nlet expand_constants_branch_cost =\n Gas_limit_repr.atomic_step_cost @@ S.safe_int 4095\n\n(* Approximating 100 + 4.639474 * n*log(n) *)\nlet expand_no_constants_branch_cost node =\n let v0 = Script_repr.micheline_nodes node |> S.safe_int in\n let v0 = S.mul v0 (log2 v0) in\n S.safe_int 100 + S.mul (S.safe_int 4) v0 + (v0 lsr 1) + (v0 lsr 3)\n |> Gas_limit_repr.atomic_step_cost\n" ;
} ;
{ name = "Global_constants_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Marigold <team@marigold.dev> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module represents access to a global table of constant\n Micheline values. Users may register a Micheline value in the\n table, paying the cost of storage. Once stored, contracts source code may\n reference this value by its hash. \n \n Note: the table does not typecheck the values stored in it.\n Instead, any place that uses constants must first call [expand]\n before typechecking the code. This decision was made to make it as\n easy as possible for users to register values to the table, and also\n to allow maximum flexibility in the use of constants for different\n parts of a Michelson script (code, types, data, etc.). *)\n\ntype error += Expression_too_deep\n\ntype error += Expression_already_registered\n\n(** A constant is the prim of the literal characters \"constant\".\n A constant must have a single argument, being a string with a\n well formed hash of a Micheline expression (i.e generated by\n [Script_expr_hash.to_b58check]). *)\ntype error += Badly_formed_constant_expression\n\ntype error += Nonexistent_global\n\n(** [get context hash] retrieves the Micheline value with the given hash.\n \n Fails with [Nonexistent_global] if no value is found at the given hash.\n\n Fails with [Storage_error Corrupted_data] if the deserialisation fails.\n \n Consumes [Gas_repr.read_bytes_cost <size of the value>]. *)\nval get :\n Raw_context.t ->\n Script_expr_hash.t ->\n (Raw_context.t * Script_repr.expr) tzresult Lwt.t\n\n(** [register context value] registers a constant in the global table of constants,\n returning the hash and storage bytes consumed.\n\n Does not type-check the Micheline code being registered, allow potentially\n ill-typed Michelson values to be stored in the table (see note at top of module).\n\n The constant is stored unexpanded, but it is temporarily expanded at registration\n time only to check the expanded version respects the following limits.\n This also ensures there are no cyclic dependencies between constants.\n\n Fails with [Expression_too_deep] if, after fully expanding all constants,\n the expression would have a depth greater than [Constant_repr.max_allowed_global_constant_depth].\n\n Fails with [Badly_formed_constant_expression] if constants are not\n well-formed (see declaration of [Badly_formed_constant_expression]) or with\n [Nonexistent_global] if a referenced constant does not exist in the table.\n\n Consumes serialization cost.\n Consumes [Gas_repr.write_bytes_cost <size>] where size is the number\n of bytes in the binary serialization provided by [Script_repr.expr_encoding]. *)\nval register :\n Raw_context.t ->\n Script_repr.expr ->\n (Raw_context.t * Script_expr_hash.t * Z.t) tzresult Lwt.t\n\n(** [expand context expr] replaces every constant in the\n given Michelson expression with its value stored in the global table.\n\n The expansion is applied recursively so that the returned expression\n contains no constant.\n\n Fails with [Badly_formed_constant_expression] if constants are not\n well-formed (see declaration of [Badly_formed_constant_expression]) or\n with [Nonexistent_global] if a referenced constant does not exist in\n the table. *)\nval expand :\n Raw_context.t ->\n Script_repr.expr ->\n (Raw_context.t * Script_repr.expr) tzresult Lwt.t\n\nmodule Internal_for_tests : sig\n (** [node_too_large node] returns true if:\n - The number of sub-nodes in the [node] \n exceeds [Global_constants_storage.node_size_limit].\n - The sum of the bytes in String, Int,\n and Bytes sub-nodes of [node] exceeds\n [Global_constants_storage.bytes_size_limit].\n \n Otherwise returns false. *)\n val node_too_large : Script_repr.node -> bool\n\n (** [bottom_up_fold_cps initial_accumulator node initial_k f]\n folds [node] and all its sub-nodes if any, starting from\n [initial_accumulator], using an initial continuation [initial_k].\n At each node, [f] is called to transform the continuation [k] into\n the next one. This explicit manipulation of the continuation\n is typically useful to short-circuit.\n\n Notice that a common source of bug is to forget to properly call the\n continuation in `f`.\n \n See [Global_constants_storage.expand] for an example.\n\n TODO: https://gitlab.com/tezos/tezos/-/issues/1609\n Move function to lib_micheline.\n\n On our next opportunity to update the environment, we\n should move this function to lib_micheline.\n *)\n val bottom_up_fold_cps :\n 'accumulator ->\n 'loc Script_repr.michelson_node ->\n ('accumulator -> 'loc Script_repr.michelson_node -> 'return) ->\n ('accumulator ->\n 'loc Script_repr.michelson_node ->\n ('accumulator -> 'loc Script_repr.michelson_node -> 'return) ->\n 'return) ->\n 'return\n\n (* [expr_to_address_in_context context expr] converts [expr]\n into a unique hash represented by a [Script_expr_hash.t].\n\n Consumes gas corresponding to the cost of converting [expr]\n to bytes and hashing the bytes. *)\n val expr_to_address_in_context :\n Raw_context.t ->\n Script_repr.expr ->\n (Raw_context.t * Script_expr_hash.t) tzresult\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Marigold <team@marigold.dev> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\nopen Micheline\nopen Michelson_v1_primitives\n\n(*\n\n See [expand] for an example.\n\n TODO: https://gitlab.com/tezos/tezos/-/issues/1609\n Move function to lib_micheline.\n\n On our next opportunity to update the environment, we\n should move this function to lib_micheline.\n\n*)\nlet bottom_up_fold_cps initial_accumulator node initial_k f =\n let rec traverse_node accu node k =\n f accu node @@ fun accu node ->\n match node with\n | String _ | Int _ | Bytes _ -> k accu node\n | Prim (loc, prim, args, annot) ->\n (traverse_nodes [@ocaml.tailcall]) accu args (fun accu args ->\n f accu (Prim (loc, prim, args, annot)) k)\n | Seq (loc, elts) ->\n (traverse_nodes [@ocaml.tailcall]) accu elts (fun accu elts ->\n f accu (Seq (loc, elts)) k)\n and traverse_nodes accu nodes k =\n match nodes with\n | [] -> k accu []\n | node :: nodes ->\n (traverse_node [@ocaml.tailcall]) accu node (fun accu node ->\n (traverse_nodes [@ocaml.tailcall]) accu nodes (fun accu nodes ->\n k accu (node :: nodes)))\n in\n traverse_node initial_accumulator node initial_k\n\nmodule Gas_costs = Global_constants_costs\nmodule Expr_hash_map = Map.Make (Script_expr_hash)\n\ntype error += Expression_too_deep\n\ntype error += Expression_already_registered\n\ntype error += Badly_formed_constant_expression\n\ntype error += Nonexistent_global\n\ntype error += Expression_too_large\n\nlet () =\n let description =\n \"Attempted to register an expression that, after fully expanding all \\\n referenced global constants, would result in too many levels of nesting.\"\n in\n register_error_kind\n `Branch\n ~id:\"Expression_too_deep\"\n ~title:\"Expression too deep\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Expression_too_deep -> Some () | _ -> None)\n (fun () -> Expression_too_deep) ;\n let description =\n \"Attempted to register an expression as global constant that has already \\\n been registered.\"\n in\n register_error_kind\n `Branch\n ~id:\"Expression_already_registered\"\n ~title:\"Expression already registered\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Expression_already_registered -> Some () | _ -> None)\n (fun () -> Expression_already_registered) ;\n let description =\n \"Found a badly formed constant expression. The 'constant' primitive must \\\n always be followed by a string of the hash of the expression it points \\\n to.\"\n in\n register_error_kind\n `Branch\n ~id:\"Badly_formed_constant_expression\"\n ~title:\"Badly formed constant expression\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Badly_formed_constant_expression -> Some () | _ -> None)\n (fun () -> Badly_formed_constant_expression) ;\n let description =\n \"No registered global was found at the given hash in storage.\"\n in\n register_error_kind\n `Branch\n ~id:\"Nonexistent_global\"\n ~title:\"Tried to look up nonexistent global\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Nonexistent_global -> Some () | _ -> None)\n (fun () -> Nonexistent_global) ;\n let description =\n \"Encountered an expression that, after expanding all constants, is larger \\\n than the expression size limit.\"\n in\n register_error_kind\n `Branch\n ~id:\"Expression_too_large\"\n ~title:\"Expression too large\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Expression_too_large -> Some () | _ -> None)\n (fun () -> Expression_too_large)\n\nlet get context hash =\n Storage.Global_constants.Map.find context hash >>=? fun (context, value) ->\n match value with\n | None -> tzfail Nonexistent_global\n | Some value -> return (context, value)\n\nlet expr_to_address_in_context context expr =\n let lexpr = Script_repr.lazy_expr expr in\n Raw_context.consume_gas context @@ Script_repr.force_bytes_cost lexpr\n >>? fun context ->\n Script_repr.force_bytes lexpr >>? fun b ->\n Raw_context.consume_gas context @@ Gas_costs.expr_to_address_in_context_cost b\n >|? fun context -> (context, Script_expr_hash.hash_bytes [b])\n\nlet node_too_large node =\n let node_size = Script_repr.Micheline_size.of_node node in\n let nodes = Saturation_repr.to_int node_size.nodes in\n let string_bytes = Saturation_repr.to_int node_size.string_bytes in\n let z_bytes = Saturation_repr.to_int node_size.z_bytes in\n Compare.Int.(\n nodes > Constants_repr.max_micheline_node_count\n || string_bytes + z_bytes > Constants_repr.max_micheline_bytes_limit)\n\nlet expand_node context node =\n (* We charge for traversing the top-level node at the beginning.\n Inside the loop, we charge for traversing each new constant\n that gets expanded. *)\n Raw_context.consume_gas\n context\n (Gas_costs.expand_no_constants_branch_cost node)\n >>?= fun context ->\n bottom_up_fold_cps\n (* We carry a Boolean representing whether we\n had to do any expansions or not. *)\n (context, Expr_hash_map.empty, false)\n node\n (fun (context, _, did_expansion) node ->\n return (context, node, did_expansion))\n (fun (context, map, did_expansion) node k ->\n match node with\n | Prim (_, H_constant, args, annot) -> (\n (* Charge for validating the b58check hash. *)\n Raw_context.consume_gas context Gas_costs.expand_constants_branch_cost\n >>?= fun context ->\n match (args, annot) with\n (* A constant Prim should always have a single String argument,\n being a properly formatted hash. *)\n | [String (_, address)], [] -> (\n match Script_expr_hash.of_b58check_opt address with\n | None -> tzfail Badly_formed_constant_expression\n | Some hash -> (\n match Expr_hash_map.find hash map with\n | Some node ->\n (* Charge traversing the newly retrieved node *)\n Raw_context.consume_gas\n context\n (Gas_costs.expand_no_constants_branch_cost node)\n >>?= fun context -> k (context, map, true) node\n | None ->\n get context hash >>=? fun (context, expr) ->\n (* Charge traversing the newly retrieved node *)\n let node = root expr in\n Raw_context.consume_gas\n context\n (Gas_costs.expand_no_constants_branch_cost node)\n >>?= fun context ->\n k (context, Expr_hash_map.add hash node map, true) node))\n | _ -> tzfail Badly_formed_constant_expression)\n | Int _ | String _ | Bytes _ | Prim _ | Seq _ ->\n k (context, map, did_expansion) node)\n >>=? fun (context, node, did_expansion) ->\n if did_expansion then\n (* Gas charged during expansion is at least proportional to the size of the\n resulting node so the execution time of [node_too_large] is already\n covered. *)\n if node_too_large node then tzfail Expression_too_large\n else return (context, node)\n else return (context, node)\n\nlet expand context expr =\n expand_node context (root expr) >|=? fun (context, node) ->\n (context, strip_locations node)\n\n(** Computes the maximum depth of a Micheline node. Fails\n with [Expression_too_deep] if greater than\n [max_allowed_global_constant_depth].*)\nlet check_depth node =\n let rec advance node depth k =\n if Compare.Int.(depth > Constants_repr.max_allowed_global_constant_depth)\n then error Expression_too_deep\n else\n match node with\n | Int _ | String _ | Bytes _ | Prim (_, _, [], _) | Seq (_, []) ->\n (k [@tailcall]) (depth + 1)\n | Prim (loc, _, hd :: tl, _) | Seq (loc, hd :: tl) ->\n (advance [@tailcall]) hd (depth + 1) (fun dhd ->\n (advance [@tailcall])\n (* Because [depth] doesn't care about the content\n of the expression, we can safely throw away information\n about primitives and replace them with the [Seq] constructor.*)\n (Seq (loc, tl))\n depth\n (fun dtl -> (k [@tailcall]) (Compare.Int.max dhd dtl)))\n in\n advance node 0 (fun x -> Ok x)\n\nlet register context value =\n (* To calculate the total depth, we first expand all constants\n in the expression. This may fail with [Expression_too_large].\n\n Though the stored expression is the unexpanded version.\n *)\n expand_node context (root value) >>=? fun (context, node) ->\n (* We do not need to carbonate [check_depth]. [expand_node] and\n [Storage.Global_constants.Map.init] are already carbonated\n with gas at least proportional to the size of the expanded node\n and the computation cost of [check_depth] is of the same order. *)\n check_depth node >>?= fun (_depth : int) ->\n expr_to_address_in_context context value >>?= fun (context, key) ->\n trace Expression_already_registered\n @@ Storage.Global_constants.Map.init context key value\n >|=? fun (context, size) -> (context, key, Z.of_int size)\n\nmodule Internal_for_tests = struct\n let node_too_large = node_too_large\n\n let bottom_up_fold_cps = bottom_up_fold_cps\n\n let expr_to_address_in_context = expr_to_address_in_context\nend\n" ;
} ;
{ name = "Tx_rollup_state_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** A collection of functions to manipulate the state of a transaction\n rollup.\n\n Except if the contrary is explicitly stated, the functions of this\n module are carbonated. *)\n\n(** [init ctxt tx_rollup] initializes the state of [tx_rollup].\n\n Returns the error [Tx_rollup_already_exists] iff this function has\n already been called for [tx_rollup], which is definitely something\n that should not happen, because the protocol is expected to pick\n fresh addresses when it originates new transaction rollups (and\n does so by relying on the \226\128\156origination nonce\226\128\157 derived from the\n hash of the operation responsible for the origination, using the\n same procedure as smart contracts).\n\n Raising this error would therefore indicate a bug in the\n protocol. *)\nval init : Raw_context.t -> Tx_rollup_repr.t -> Raw_context.t tzresult Lwt.t\n\n(** [find ctxt tx_rollup] returns the current state of [tx_rollup]. If\n [tx_rollup] is not the address of an existing transaction rollup,\n [None] is returned instead. *)\nval find :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n (Raw_context.t * Tx_rollup_state_repr.t option) tzresult Lwt.t\n\n(** [get ctxt tx_rollup] returns the current state of [tx_rollup] in\n the context.\n\n Returns the [Tx_rollup_does_not_exist] error iff [tx_rollup] is\n not the address of an existing transaction rollup. *)\nval get :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n (Raw_context.t * Tx_rollup_state_repr.t) tzresult Lwt.t\n\n(** [update ctxt tx_rollup new_state] replaces the stored state of\n [tx_rollup] with [new_state]. *)\nval update :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Tx_rollup_state_repr.t ->\n Raw_context.t tzresult Lwt.t\n\n(** [assert_exist ctxt tx_rollup] fails with\n [Tx_rollup_does_not_exist] when [tx_rollup] is not a valid\n transaction rollup address. *)\nval assert_exist :\n Raw_context.t -> Tx_rollup_repr.t -> Raw_context.t tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Tx_rollup_errors_repr\n\nlet init : Raw_context.t -> Tx_rollup_repr.t -> Raw_context.t tzresult Lwt.t =\n fun ctxt tx_rollup ->\n Storage.Tx_rollup.State.mem ctxt tx_rollup >>=? fun (ctxt, already_exists) ->\n fail_when already_exists (Tx_rollup_already_exists tx_rollup) >>=? fun () ->\n let pre_allocated_storage =\n Z.of_int @@ Constants_storage.tx_rollup_origination_size ctxt\n in\n Storage.Tx_rollup.State.init ctxt tx_rollup\n @@ Tx_rollup_state_repr.initial_state ~pre_allocated_storage\n >|=? fst\n\nlet find :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n (Raw_context.t * Tx_rollup_state_repr.t option) tzresult Lwt.t =\n Storage.Tx_rollup.State.find\n\nlet get :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n (Raw_context.t * Tx_rollup_state_repr.t) tzresult Lwt.t =\n fun ctxt tx_rollup ->\n find ctxt tx_rollup >>=? fun (ctxt, state) ->\n match state with\n | Some state -> return (ctxt, state)\n | None -> tzfail (Tx_rollup_does_not_exist tx_rollup)\n\nlet assert_exist :\n Raw_context.t -> Tx_rollup_repr.t -> Raw_context.t tzresult Lwt.t =\n fun ctxt tx_rollup ->\n Storage.Tx_rollup.State.mem ctxt tx_rollup\n >>=? fun (ctxt, tx_rollup_exists) ->\n fail_unless tx_rollup_exists (Tx_rollup_does_not_exist tx_rollup)\n >>=? fun () -> return ctxt\n\nlet update :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Tx_rollup_state_repr.t ->\n Raw_context.t tzresult Lwt.t =\n fun ctxt tx_rollup t ->\n Storage.Tx_rollup.State.update ctxt tx_rollup t >>=? fun (ctxt, _) ->\n return ctxt\n" ;
} ;
{ name = "Tx_rollup_reveal_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** [record ctxt tx_rollup lvl message_position] adds\n [message_position] to the list of message with revealed\n withdrawals for [tx_rollup] at [lvl]. *)\nval record :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Tx_rollup_level_repr.t ->\n message_position:int ->\n Raw_context.t tzresult Lwt.t\n\n(** [mem ctxt tx_rollup lvl message_position] checks if\n [message_position] has already had its withdrawals revealed for\n [tx_rollup] at [lvl]. *)\nval mem :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Tx_rollup_level_repr.t ->\n message_position:int ->\n (Raw_context.t * bool) tzresult Lwt.t\n\n(** [remove ctxt tx_rollup lvl] clean-up the reveal accounting data\n from the layer-1 storage. *)\nval remove :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Tx_rollup_level_repr.t ->\n Raw_context.t tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nlet record ctxt tx_rollup level ~message_position =\n Storage.Tx_rollup.Revealed_withdrawals.find (ctxt, tx_rollup) level\n >>=? fun (ctxt, revealed_withdrawals_opt) ->\n Bitset.add\n (Option.value ~default:Bitset.empty revealed_withdrawals_opt)\n message_position\n >>?= fun revealed_withdrawals ->\n Storage.Tx_rollup.Revealed_withdrawals.add\n (ctxt, tx_rollup)\n level\n revealed_withdrawals\n >>=? fun (ctxt, _new_size, _is_new) -> return ctxt\n(* See {{Note}} in [Tx_rollup_commitment_storage] for a rationale on\n why ignoring storage allocation is safe. *)\n\nlet mem ctxt tx_rollup level ~message_position =\n Storage.Tx_rollup.Revealed_withdrawals.find (ctxt, tx_rollup) level\n >>=? fun (ctxt, revealed_withdrawals_opt) ->\n match revealed_withdrawals_opt with\n | Some field ->\n Bitset.mem field message_position >>?= fun res -> return (ctxt, res)\n | None -> return (ctxt, false)\n\nlet remove ctxt tx_rollup level =\n Storage.Tx_rollup.Revealed_withdrawals.remove (ctxt, tx_rollup) level\n >>=? fun (ctxt, _freed_size, _existed) -> return ctxt\n(* See {{Note}} in [Tx_rollup_commitment_storage] for a rationale on\n why ignoring storage allocation is safe. *)\n" ;
} ;
{ name = "Tx_rollup_inbox_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Functions to manipulate transaction rollup\226\128\153s inboxes.\n\n Except explicit mention of the contrary, all the functions of this\n module are carbonated. *)\n\n(** [append_message ctxt tx_rollup state message] tries to append\n [message] to the inbox of [tx_rollup] at the current level, creating\n it in the process if need be. This function returns the size of the\n appended message (in bytes), in order for the appropriate burn to be\n taken from the message author, the new state, as well as the storage\n size diff. It is the caller's responsibility to store the returned state.\n\n {b Note:} [tx_rollup] needs to be a valid transaction address. It\n is the responsibility of the caller to assert it.\n\n Returns the error\n\n {ul {li [Inbox_size_would_exceed_limit] if appending [message] to\n the inbox would make it exceed the maximum size specified\n by the [tx_rollup_hard_size_limit_per_inbox] protocol\n parameter.}\n {li [Message_size_exceeds_limit] if the size of [message] is\n greater than the [tx_rollup_hard_size_limit_per_message]\n protocol parameter.}} *)\nval append_message :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Tx_rollup_state_repr.t ->\n Tx_rollup_message_repr.t ->\n (Raw_context.t * Tx_rollup_state_repr.t * Z.t) tzresult Lwt.t\n\n(** [get ctxt level tx_rollup] returns the inbox of [tx_rollup] at\n level [level].\n\n Returns the errors\n\n {ul {li [Inbox_does_not_exist] iff [tx_rollup] does not have an\n inbox at level [level]. }} *)\nval get :\n Raw_context.t ->\n Tx_rollup_level_repr.t ->\n Tx_rollup_repr.t ->\n (Raw_context.t * Tx_rollup_inbox_repr.t) tzresult Lwt.t\n\n(** [find ctxt level tx_rollup] returns the inbox of [tx_rollup] at\n level [level].\n\n Returns [None] when the similar function [get] returns an\n error. *)\nval find :\n Raw_context.t ->\n Tx_rollup_level_repr.t ->\n Tx_rollup_repr.t ->\n (Raw_context.t * Tx_rollup_inbox_repr.t option) tzresult Lwt.t\n\n(** [remove ctxt level tx_rollup] removes from the context the inbox\n of [level].\n\n It is expected that this function is only called for inboxes that\n has been \226\128\156adopted\226\128\157 by a commitment. As a consequence, the storage\n accounting is not performed by this function.\n\n This function will returns the error [Inbox_does_not_exist] if\n there is no inbox for [level] in the storage. It is the\n reponsibility of the caller to ensure the [tx_rollup] actually\n exists. *)\nval remove :\n Raw_context.t ->\n Tx_rollup_level_repr.t ->\n Tx_rollup_repr.t ->\n Raw_context.t tzresult Lwt.t\n\n(** [check_message_hash ctxt level tx_rollup position message path]\n checks that [message] is part of the [tx_rollup] inbox for [level]\n by checking the merkelised proof given by [path].\n\n If the proof failed, returns [Wrong_message_path]. *)\nval check_message_hash :\n Raw_context.t ->\n Tx_rollup_level_repr.t ->\n Tx_rollup_repr.t ->\n position:int ->\n Tx_rollup_message_repr.t ->\n Tx_rollup_inbox_repr.Merkle.path ->\n Raw_context.t tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Tx_rollup_errors_repr\n\nlet find :\n Raw_context.t ->\n Tx_rollup_level_repr.t ->\n Tx_rollup_repr.t ->\n (Raw_context.t * Tx_rollup_inbox_repr.t option) tzresult Lwt.t =\n fun ctxt level tx_rollup ->\n Storage.Tx_rollup.Inbox.find (ctxt, tx_rollup) level\n\nlet get :\n Raw_context.t ->\n Tx_rollup_level_repr.t ->\n Tx_rollup_repr.t ->\n (Raw_context.t * Tx_rollup_inbox_repr.t) tzresult Lwt.t =\n fun ctxt level tx_rollup ->\n find ctxt level tx_rollup >>=? function\n | _, None -> tzfail (Inbox_does_not_exist (tx_rollup, level))\n | ctxt, Some inbox -> return (ctxt, inbox)\n\n(** [prepare_inbox ctxt rollup state level] prepares the metadata\n for an inbox at [level], which may imply creating it if it does\n not already exist. *)\nlet prepare_inbox :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Tx_rollup_state_repr.t ->\n Raw_level_repr.t ->\n (Raw_context.t\n * Tx_rollup_state_repr.t\n * Tx_rollup_level_repr.t\n * Tx_rollup_inbox_repr.t\n * Z.t)\n tzresult\n Lwt.t =\n fun ctxt rollup state level ->\n (* First, check if there are too many inboxes *)\n fail_when\n Compare.Int.(\n Constants_storage.tx_rollup_max_inboxes_count ctxt\n <= Tx_rollup_state_repr.inboxes_count state)\n Too_many_inboxes\n >>=? fun () ->\n let current_levels = Tx_rollup_state_repr.head_levels state in\n match current_levels with\n | Some (_, tezos_lvl) when Raw_level_repr.(level < tezos_lvl) ->\n tzfail (Internal_error \"Trying to write into an inbox from the past\")\n | Some (tx_lvl, tezos_lvl) when Raw_level_repr.(tezos_lvl = level) ->\n (* An inbox should already exists *)\n Storage.Tx_rollup.Inbox.get (ctxt, rollup) tx_lvl\n >>=? fun (ctxt, metadata) -> return (ctxt, state, tx_lvl, metadata, Z.zero)\n | _ ->\n let pred_level_and_tx_level =\n Option.bind current_levels (fun (tx_level, tezos_level) ->\n Option.map (fun pred -> (pred, tezos_level))\n @@ Tx_rollup_level_repr.pred tx_level)\n in\n (match pred_level_and_tx_level with\n | None -> return (ctxt, state)\n | Some (tx_level, tezos_level) ->\n find ctxt tx_level rollup >>=? fun (ctxt, minbox) ->\n (* If the previous inbox is no longer in the storage, then\n quite some Tezos blocks have been created without any\n activity regarding this rollup. We can consider the inbox\n was empty, it does not change much. *)\n let final_size =\n match minbox with Some inbox -> inbox.cumulated_size | None -> 0\n in\n let hard_limit =\n Constants_storage.tx_rollup_hard_size_limit_per_inbox ctxt\n in\n let factor =\n Constants_storage.tx_rollup_cost_per_byte_ema_factor ctxt\n in\n let diff = Raw_level_repr.diff level tezos_level in\n (* Only [diff = Int32.one] should be checked\n theoretically. If [diff < Int32.one], it likely\n means there is a problem in the state machine since\n this function was called twice for the same\n level. This problem is caught at other\n places. However, if this assumption is broken, I\n prefer to consider that it counts as if there was\n no empty blocks between the first call and the\n second call to this function. *)\n let elapsed =\n if Compare.Int32.(diff <= Int32.one) then 0 else Int32.to_int diff\n in\n let state =\n Tx_rollup_state_repr.update_burn_per_byte\n state\n ~elapsed\n ~factor\n ~final_size\n ~hard_limit\n in\n Storage.Tx_rollup.State.add ctxt rollup state >|=? fun (ctxt, _, _) ->\n (ctxt, state))\n >>=? fun (ctxt, state) ->\n (* We need a new inbox *)\n Tx_rollup_state_repr.record_inbox_creation state level\n >>?= fun (state, tx_level, paid_storage_space_diff) ->\n let inbox = Tx_rollup_inbox_repr.empty in\n Storage.Tx_rollup.Inbox.init (ctxt, rollup) tx_level inbox\n >>=? fun (ctxt, _inbox_size_alloc) ->\n (* Storage accounting is done by\n [Tx_rollup_state_repr.record_inbox_creation], so we can\n ignore [inbox_size_alloc]. *)\n return (ctxt, state, tx_level, inbox, paid_storage_space_diff)\n\n(** [update_inbox inbox msg_size] updates [metadata] to account\n for a new message of [msg_size] bytes. *)\nlet update_inbox :\n Tx_rollup_inbox_repr.t ->\n int ->\n Tx_rollup_inbox_repr.Merkle.root ->\n Tx_rollup_inbox_repr.t =\n fun metadata msg_size merkle_root ->\n Tx_rollup_inbox_repr.\n {\n inbox_length = 1 + metadata.inbox_length;\n cumulated_size = msg_size + metadata.cumulated_size;\n merkle_root;\n }\n\nlet append_message :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Tx_rollup_state_repr.t ->\n Tx_rollup_message_repr.t ->\n (Raw_context.t * Tx_rollup_state_repr.t * Z.t) tzresult Lwt.t =\n fun ctxt rollup state message ->\n let level = (Raw_context.current_level ctxt).level in\n let message_size = Tx_rollup_message_repr.size message in\n (* Update the burn cost to pay for appending new messages *)\n prepare_inbox ctxt rollup state level\n >>=? fun ( ctxt,\n new_state,\n tx_level,\n inbox,\n paid_storage_space_diff_for_init_inbox ) ->\n fail_when\n Compare.Int.(\n inbox.inbox_length\n >= Constants_storage.tx_rollup_max_messages_per_inbox ctxt)\n (Inbox_count_would_exceed_limit rollup)\n >>=? fun () ->\n Tx_rollup_hash_builder.message ctxt message >>?= fun (ctxt, message_hash) ->\n Tx_rollup_gas.consume_add_message_cost ctxt >>?= fun ctxt ->\n let ctxt, inbox_merkle_root =\n Raw_context.Tx_rollup.add_message ctxt rollup message_hash\n in\n let new_inbox = update_inbox inbox message_size inbox_merkle_root in\n let new_size = new_inbox.cumulated_size in\n let inbox_limit =\n Constants_storage.tx_rollup_hard_size_limit_per_inbox ctxt\n in\n fail_unless\n Compare.Int.(new_size <= inbox_limit)\n (Inbox_size_would_exceed_limit rollup)\n >>=? fun () ->\n (* Checks have passed, so we can actually record in the storage. *)\n Storage.Tx_rollup.Inbox.add (ctxt, rollup) tx_level new_inbox\n >>=? fun (ctxt, new_inbox_size_alloc, _) ->\n Tx_rollup_state_repr.adjust_storage_allocation\n new_state\n ~delta:Z.(of_int new_inbox_size_alloc)\n >>?= fun (new_state, paid_storage_space_diff) ->\n return\n ( ctxt,\n new_state,\n Z.add paid_storage_space_diff_for_init_inbox paid_storage_space_diff )\n\nlet remove :\n Raw_context.t ->\n Tx_rollup_level_repr.t ->\n Tx_rollup_repr.t ->\n Raw_context.t tzresult Lwt.t =\n fun ctxt level rollup ->\n Storage.Tx_rollup.Inbox.remove (ctxt, rollup) level\n >>=? fun (ctxt, _freed, _) -> return ctxt\n\nlet check_message_hash :\n Raw_context.t ->\n Tx_rollup_level_repr.t ->\n Tx_rollup_repr.t ->\n position:int ->\n Tx_rollup_message_repr.t ->\n Tx_rollup_inbox_repr.Merkle.path ->\n Raw_context.t tzresult Lwt.t =\n fun ctxt level tx_rollup ~position message path ->\n Storage.Tx_rollup.Inbox.get (ctxt, tx_rollup) level >>=? fun (ctxt, inbox) ->\n Tx_rollup_hash_builder.message ctxt message >>?= fun (ctxt, message_hash) ->\n Tx_rollup_gas.consume_check_path_inbox_cost ctxt >>?= fun ctxt ->\n Tx_rollup_inbox_repr.Merkle.check_path\n path\n position\n message_hash\n inbox.merkle_root\n >>?= fun b ->\n fail_unless b (Wrong_message_path {expected = inbox.merkle_root})\n >>=? fun () -> return ctxt\n" ;
} ;
{ name = "Tx_rollup_commitment_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2021 Oxhead Alpha <info@oxheadalpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module introduces various functions to manipulate the storage related\n to commitments for transaction rollups. *)\n\nval check_message_result :\n Raw_context.t ->\n Tx_rollup_commitment_repr.Compact.t ->\n [ `Hash of Tx_rollup_message_result_hash_repr.t\n | `Result of Tx_rollup_message_result_repr.t ] ->\n path:Tx_rollup_commitment_repr.Merkle.path ->\n index:int ->\n Raw_context.t tzresult\n\n(** [add_commitment context tx_rollup contract commitment] adds a\n commitment to a rollup. It returns the new context, the new state,\n and the committer of the previous commitment stored for this\n level if any.\n\n In case this committer exists, then it means its bond needs to be\n slashed.\n\n This function returns the errors\n\n {ul {li [Level_already_has_commitment] iff there is already a\n valid commitment ({i i.e.}, not orphan) at this level.}\n {li [Invalid_committer] iff an orphan commitment from the same\n committer already is in the storage.}\n {li [Missing_commitment_predecessor] iff the predecessor does\n not match the already-stored predecessor commitment.}\n {li [Wrong_commitment_predecessor_level] iff there is no\n predecessor level, but a predecessor commitment is\n provided (or no predecessor commitment is provided but\n there is a precessor level)}\n {li [Wrong_batch_count] iff the number of batches does not\n equal the length of the inbox.}} *)\nval add_commitment :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Tx_rollup_state_repr.t ->\n Signature.Public_key_hash.t ->\n Tx_rollup_commitment_repr.Full.t ->\n (Raw_context.t * Tx_rollup_state_repr.t * Signature.public_key_hash option)\n tzresult\n Lwt.t\n\n(** [remove_bond context state tx_rollup contract] removes the bond for an\n implicit contract. This will fail if either the bond does not exist,\n or if the bond is currently in use. *)\nval remove_bond :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Signature.public_key_hash ->\n Raw_context.t tzresult Lwt.t\n\n(** [slash_bond ctxt tx_rollup contract] removes the bond counter for\n an implicit contract if it exists. Besides, it returns a boolean\n to determine if this counter was strictly superior to 0. *)\nval slash_bond :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Signature.public_key_hash ->\n (Raw_context.t * bool) tzresult Lwt.t\n\n(** [find context tx_rollup state level] returns the commitment for a\n level, if any exists and is not orphan (that is, one of its\n ancestors has been rejected). If the rollup does not exist, the\n error [Tx_rollup_does_not_exist] is returned. *)\nval find :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Tx_rollup_state_repr.t ->\n Tx_rollup_level_repr.t ->\n (Raw_context.t * Tx_rollup_commitment_repr.Submitted_commitment.t option)\n tzresult\n Lwt.t\n\n(** [get context tx_rollup state level] returns the commitment for a\n level, if any exists. If the rollup does not exist, the error\n [Tx_rollup_does_not_exist] is returned. If there is no commitment\n in the storage, or if a commitment exists but it is orphan (that\n is, one of its ancestors has been rejected), then\n [Commitment_does_not_exist] is returned. *)\nval get :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Tx_rollup_state_repr.t ->\n Tx_rollup_level_repr.t ->\n (Raw_context.t * Tx_rollup_commitment_repr.Submitted_commitment.t) tzresult\n Lwt.t\n\n(** [get_finalized context tx_rollup level] returns the\n commitment for a level, if any exists and is finalized. If the rollup does not\n exist, the error [Tx_rollup_does_not_exist] is returned. If the commitment\n is not finalized the error [Tx_rollup_commitment_not_final] is returned *)\nval get_finalized :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Tx_rollup_state_repr.t ->\n Tx_rollup_level_repr.t ->\n (Raw_context.t * Tx_rollup_commitment_repr.Submitted_commitment.t) tzresult\n Lwt.t\n\n(** [pending_bonded_commitments ctxt tx_rollup contract] returns the\n number of commitments that [contract] has made that are still\n in the storage. *)\nval pending_bonded_commitments :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Signature.public_key_hash ->\n (Raw_context.t * int) tzresult Lwt.t\n\n(** [has_bond ctxt tx_rollup contract] returns true if we have\n already collected a bond for [contract] for commitments on\n [tx_rollup]. *)\nval has_bond :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Signature.public_key_hash ->\n (Raw_context.t * bool) tzresult Lwt.t\n\n(** [finalize_commitment ctxt tx_rollup state] marks the commitment of\n the oldest inbox as final, if the commitment exists and if it is\n old enough. Otherwise, this function returns the error\n [No_commitment_to_finalize].\n\n The number of {!pending_bonded_commitments} is not updated, it\n is decremented when the commitment is removed (see {!remove_commitment}).\n It is done to force the rollup operators to clean up the commitment storage.\n\n The state of the rollup is adjusted accordingly, and the finalized\n level is returned. Besides, the inbox at said level is removed\n from the context. This function returns the new context, and the\n new state. *)\nval finalize_commitment :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Tx_rollup_state_repr.t ->\n (Raw_context.t * Tx_rollup_state_repr.t * Tx_rollup_level_repr.t) tzresult\n Lwt.t\n\n(** [remove_commitment ctxt tx_rollup state] tries to remove the\n oldest finalized commitment from the layer-1 storage, if it\n exists, and if it is old enough. Otherwise, this functions returns\n the error [No_commitment_to_remove].\n\n The state of the rollup is adjusted accordingly. *)\nval remove_commitment :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Tx_rollup_state_repr.t ->\n (Raw_context.t * Tx_rollup_state_repr.t * Tx_rollup_level_repr.t) tzresult\n Lwt.t\n\n(** [reject_commitment context tx_rollup state level] removes the\n commitment at [level]. It should only be called after a\n successful rejection operation. The [state] is updated to reflect\n the rejection, and returned. *)\nval reject_commitment :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Tx_rollup_state_repr.t ->\n Tx_rollup_level_repr.t ->\n (Raw_context.t * Tx_rollup_state_repr.t) tzresult Lwt.t\n\nval check_agreed_and_disputed_results :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Tx_rollup_state_repr.t ->\n Tx_rollup_commitment_repr.Submitted_commitment.t ->\n agreed_result:Tx_rollup_message_result_repr.t ->\n agreed_result_path:Tx_rollup_commitment_repr.Merkle.path ->\n disputed_result:Tx_rollup_message_result_hash_repr.t ->\n disputed_position:int ->\n disputed_result_path:Tx_rollup_commitment_repr.Merkle.path ->\n Raw_context.t tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2021 Oxhead Alpha <info@oxheadalpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Tx_rollup_commitment_repr\nopen Tx_rollup_errors_repr\n\n(*\n\n {{Note}} The functions of this module ignore storage allocations on\n purposes. This is because any storage allocated here is done under\n the condition that a user has agreed to freeze a significant bond\n of tez.\n\n Not only this bond covers the maximum number of bytes a transaction\n rollup can allocate, but it can be recovered iff the storage\n associated with this bond is deallocated. In other word, rollup\n operators have an incentive to keep the storage clean.\n\n {{Note inbox}} The only storage that is not directly covered by the\n bond are the inboxes. As a consequence, inboxes allocations are\n still recorded normally. However, as soon as an inbox is committed\n to, then it needs to be deleted for the bond to be retreived (as\n part of the commitment finalization). As a consequence, we\n virtually free the storage by an inbox (as accounted for by the\n rollup) when it is committed to.\n\n *)\n\nlet check_message_result ctxt {messages; _} result ~path ~index =\n (match result with\n | `Hash hash -> ok (ctxt, hash)\n | `Result result -> Tx_rollup_hash_builder.message_result ctxt result)\n >>? fun (ctxt, computed) ->\n Tx_rollup_gas.consume_check_path_commitment_cost ctxt >>? fun ctxt ->\n let cond =\n match\n Merkle.check_path\n path\n index\n computed\n messages.Tx_rollup_commitment_repr.Compact.root\n with\n | Ok x -> x\n | Error _ -> false\n in\n error_unless\n cond\n Tx_rollup_errors_repr.(\n Wrong_rejection_hash\n {provided = computed; expected = `Valid_path (messages.root, index)})\n >>? fun () -> ok ctxt\n\nlet adjust_commitments_count ctxt tx_rollup pkh ~(dir : [`Incr | `Decr]) =\n let delta = match dir with `Incr -> 1 | `Decr -> -1 in\n Storage.Tx_rollup.Commitment_bond.find (ctxt, tx_rollup) pkh\n >>=? fun (ctxt, commitment) ->\n let count =\n match commitment with Some count -> count + delta | None -> delta\n in\n fail_when Compare.Int.(count < 0) (Commitment_bond_negative count)\n >>=? fun () ->\n Storage.Tx_rollup.Commitment_bond.add (ctxt, tx_rollup) pkh count\n >>=? fun (ctxt, _, _) -> return ctxt\n\nlet remove_bond :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Signature.public_key_hash ->\n Raw_context.t tzresult Lwt.t =\n fun ctxt tx_rollup contract ->\n Storage.Tx_rollup.Commitment_bond.find (ctxt, tx_rollup) contract\n >>=? fun (ctxt, bond) ->\n match bond with\n | None -> tzfail (Bond_does_not_exist contract)\n | Some 0 ->\n Storage.Tx_rollup.Commitment_bond.remove (ctxt, tx_rollup) contract\n >>=? fun (ctxt, _, _) -> return ctxt\n | Some _ -> tzfail (Bond_in_use contract)\n\nlet slash_bond ctxt tx_rollup contract =\n Storage.Tx_rollup.Commitment_bond.find (ctxt, tx_rollup) contract\n >>=? fun (ctxt, bond_counter) ->\n match bond_counter with\n | None -> return (ctxt, false)\n | Some c ->\n Storage.Tx_rollup.Commitment_bond.remove (ctxt, tx_rollup) contract\n >>=? fun (ctxt, _, _) -> return (ctxt, Compare.Int.(0 < c))\n\nlet find :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Tx_rollup_state_repr.t ->\n Tx_rollup_level_repr.t ->\n (Raw_context.t * Submitted_commitment.t option) tzresult Lwt.t =\n fun ctxt tx_rollup state level ->\n if Tx_rollup_state_repr.has_valid_commitment_at state level then\n Storage.Tx_rollup.Commitment.find (ctxt, tx_rollup) level\n >>=? fun (ctxt, commitment) ->\n match commitment with\n | None ->\n Tx_rollup_state_storage.assert_exist ctxt tx_rollup >>=? fun ctxt ->\n return (ctxt, None)\n | Some res -> return (ctxt, Some res)\n else return (ctxt, None)\n\nlet get :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Tx_rollup_state_repr.t ->\n Tx_rollup_level_repr.t ->\n (Raw_context.t * Submitted_commitment.t) tzresult Lwt.t =\n fun ctxt tx_rollup state level ->\n find ctxt tx_rollup state level >>=? fun (ctxt, commitment) ->\n match commitment with\n | None -> tzfail @@ Tx_rollup_errors_repr.Commitment_does_not_exist level\n | Some commitment -> return (ctxt, commitment)\n\nlet get_finalized :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Tx_rollup_state_repr.t ->\n Tx_rollup_level_repr.t ->\n (Raw_context.t * Submitted_commitment.t) tzresult Lwt.t =\n fun ctxt tx_rollup state level ->\n let window = Tx_rollup_state_repr.finalized_commitments_range state in\n (match window with\n | Some (first, last) ->\n error_unless\n Tx_rollup_level_repr.(first <= level && level <= last)\n (Tx_rollup_errors_repr.No_finalized_commitment_for_level {level; window})\n | None ->\n error\n (Tx_rollup_errors_repr.No_finalized_commitment_for_level {level; window}))\n >>?= fun () ->\n Storage.Tx_rollup.Commitment.find (ctxt, tx_rollup) level\n >>=? fun (ctxt, commitment) ->\n match commitment with\n | None -> tzfail @@ Tx_rollup_errors_repr.Commitment_does_not_exist level\n | Some commitment -> return (ctxt, commitment)\n\nlet check_commitment_level current_level state commitment =\n Tx_rollup_state_repr.next_commitment_level state current_level\n >>? fun expected_level ->\n error_when\n Tx_rollup_level_repr.(commitment.level < expected_level)\n (Level_already_has_commitment commitment.level)\n >>? fun () ->\n error_when\n Tx_rollup_level_repr.(expected_level < commitment.level)\n (Commitment_too_early\n {provided = commitment.level; expected = expected_level})\n\n(** [check_commitment_predecessor ctxt tx_rollup state commitment]\n will raise an error if the [predecessor] field of [commitment] is\n not consistent with the context, assuming its [level] field is\n correct. *)\nlet check_commitment_predecessor ctxt state commitment =\n match\n ( commitment.predecessor,\n Tx_rollup_state_repr.next_commitment_predecessor state )\n with\n | Some pred_hash, Some expected_hash when Hash.(pred_hash = expected_hash) ->\n return ctxt\n | None, None -> return ctxt\n | provided, expected -> tzfail (Wrong_predecessor_hash {provided; expected})\n\nlet check_commitment_batches_and_merkle_root ctxt state inbox commitment =\n let Tx_rollup_inbox_repr.{inbox_length; merkle_root; _} = inbox in\n fail_unless\n Compare.List_length_with.(commitment.messages = inbox_length)\n Wrong_batch_count\n >>=? fun () ->\n fail_unless\n Tx_rollup_inbox_repr.Merkle.(commitment.inbox_merkle_root = merkle_root)\n Wrong_inbox_hash\n >>=? fun () -> return (ctxt, state)\n\nlet add_commitment ctxt tx_rollup state pkh commitment =\n let commitment_limit =\n Constants_storage.tx_rollup_max_commitments_count ctxt\n in\n fail_when\n Compare.Int.(\n Tx_rollup_state_repr.commitments_count state >= commitment_limit)\n Too_many_commitments\n >>=? fun () ->\n (* Check the commitment has the correct values *)\n let current_level = (Raw_context.current_level ctxt).level in\n check_commitment_level current_level state commitment >>?= fun () ->\n check_commitment_predecessor ctxt state commitment >>=? fun ctxt ->\n Tx_rollup_inbox_storage.get ctxt commitment.level tx_rollup\n >>=? fun (ctxt, inbox) ->\n check_commitment_batches_and_merkle_root ctxt state inbox commitment\n >>=? fun (ctxt, state) ->\n (* De we need to slash someone? *)\n Storage.Tx_rollup.Commitment.find (ctxt, tx_rollup) commitment.level\n >>=? fun (ctxt, invalid_commitment) ->\n Option.map_e\n (fun x ->\n let to_slash = x.Submitted_commitment.committer in\n error_when Signature.Public_key_hash.(pkh = to_slash) Invalid_committer\n >>? fun () -> ok to_slash)\n invalid_commitment\n >>?= fun to_slash ->\n (* Everything has been sorted out, let\226\128\153s update the storage *)\n Tx_rollup_gas.consume_compact_commitment_cost ctxt inbox.inbox_length\n >>?= fun ctxt ->\n let commitment = Tx_rollup_commitment_repr.Full.compact commitment in\n Tx_rollup_hash_builder.compact_commitment ctxt commitment\n >>?= fun (ctxt, commitment_hash) ->\n let submitted : Tx_rollup_commitment_repr.Submitted_commitment.t =\n {\n commitment;\n commitment_hash;\n committer = pkh;\n submitted_at = current_level;\n finalized_at = None;\n }\n in\n Storage.Tx_rollup.Commitment.add (ctxt, tx_rollup) commitment.level submitted\n >>=? fun (ctxt, _commitment_size_alloc, _) ->\n (* See {{Note}} for a rationale on why ignoring storage allocation is safe. *)\n Tx_rollup_state_repr.record_commitment_creation\n state\n commitment.level\n commitment_hash\n >>?= fun state ->\n adjust_commitments_count ctxt tx_rollup pkh ~dir:`Incr >>=? fun ctxt ->\n return (ctxt, state, to_slash)\n\nlet pending_bonded_commitments :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Signature.public_key_hash ->\n (Raw_context.t * int) tzresult Lwt.t =\n fun ctxt tx_rollup pkh ->\n Storage.Tx_rollup.Commitment_bond.find (ctxt, tx_rollup) pkh\n >|=? fun (ctxt, pending) -> (ctxt, Option.value ~default:0 pending)\n\nlet has_bond :\n Raw_context.t ->\n Tx_rollup_repr.t ->\n Signature.public_key_hash ->\n (Raw_context.t * bool) tzresult Lwt.t =\n fun ctxt tx_rollup pkh ->\n Storage.Tx_rollup.Commitment_bond.find (ctxt, tx_rollup) pkh\n >|=? fun (ctxt, pending) -> (ctxt, Option.is_some pending)\n\nlet finalize_commitment ctxt rollup state =\n match Tx_rollup_state_repr.next_commitment_to_finalize state with\n | Some oldest_inbox_level ->\n (* Since the commitment head is not null, we know the oldest\n inbox has a commitment. *)\n get ctxt rollup state oldest_inbox_level >>=? fun (ctxt, commitment) ->\n (* Is the finality period for this commitment over? *)\n let finality_period = Constants_storage.tx_rollup_finality_period ctxt in\n let current_level = (Raw_context.current_level ctxt).level in\n fail_when\n Raw_level_repr.(\n current_level < add commitment.submitted_at finality_period)\n No_commitment_to_finalize\n >>=? fun () ->\n (* We remove the inbox *)\n Tx_rollup_inbox_storage.remove ctxt oldest_inbox_level rollup\n >>=? fun ctxt ->\n (* We update the commitment to mark it as finalized *)\n Storage.Tx_rollup.Commitment.update\n (ctxt, rollup)\n oldest_inbox_level\n {commitment with finalized_at = Some current_level}\n >>=? fun (ctxt, _commitment_size_alloc) ->\n (* See {{Note}} for a rationale on why ignoring storage\n allocation is safe. *)\n (* We update the state *)\n Tx_rollup_state_repr.record_inbox_deletion state oldest_inbox_level\n >>?= fun state -> return (ctxt, state, oldest_inbox_level)\n | None -> tzfail No_commitment_to_finalize\n\nlet remove_commitment ctxt rollup state =\n match Tx_rollup_state_repr.next_commitment_to_remove state with\n | Some tail ->\n (* We check the commitment is old enough *)\n get ctxt rollup state tail >>=? fun (ctxt, commitment) ->\n (match commitment.finalized_at with\n | Some finalized_at ->\n let withdraw_period =\n Constants_storage.tx_rollup_withdraw_period ctxt\n in\n let current_level = (Raw_context.current_level ctxt).level in\n fail_when\n Raw_level_repr.(current_level < add finalized_at withdraw_period)\n Remove_commitment_too_early\n | None ->\n (* unreachable code if the implementation is correct *)\n tzfail (Internal_error \"Missing finalized_at field\"))\n >>=? fun () ->\n (* Decrement the bond count of the committer *)\n adjust_commitments_count ctxt rollup commitment.committer ~dir:`Decr\n >>=? fun ctxt ->\n (* We remove the commitment *)\n Storage.Tx_rollup.Commitment.remove (ctxt, rollup) tail\n >>=? fun (ctxt, _freed_size, _existed) ->\n (* See {{Note}} for a rationale on why ignoring storage\n allocation is safe. *)\n Tx_rollup_reveal_storage.remove ctxt rollup tail >>=? fun ctxt ->\n (* We update the state *)\n let msg_hash = commitment.commitment.messages.last_result_message_hash in\n Tx_rollup_state_repr.record_commitment_deletion\n state\n tail\n commitment.commitment_hash\n msg_hash\n >>?= fun state -> return (ctxt, state, tail)\n | None -> tzfail No_commitment_to_remove\n\nlet check_agreed_and_disputed_results ctxt tx_rollup state\n (submitted_commitment : Submitted_commitment.t) ~agreed_result\n ~agreed_result_path ~disputed_result ~disputed_position\n ~disputed_result_path =\n let commitment = submitted_commitment.commitment in\n Tx_rollup_state_repr.check_level_can_be_rejected state commitment.level\n >>?= fun () ->\n check_message_result\n ctxt\n commitment\n (`Hash disputed_result)\n ~path:disputed_result_path\n ~index:disputed_position\n >>?= fun ctxt ->\n if Compare.Int.(disputed_position = 0) then\n Tx_rollup_hash_builder.message_result ctxt agreed_result\n >>?= fun (ctxt, agreed) ->\n match Tx_rollup_level_repr.pred commitment.level with\n | None ->\n let expected = Tx_rollup_message_result_hash_repr.init in\n fail_unless\n Tx_rollup_message_result_hash_repr.(agreed = expected)\n (Wrong_rejection_hash {provided = agreed; expected = `Hash expected})\n >>=? fun () -> return ctxt\n | Some pred_level -> (\n Storage.Tx_rollup.Commitment.find (ctxt, tx_rollup) pred_level\n >>=? fun (ctxt, candidate) ->\n match candidate with\n | Some commitment ->\n let expected =\n commitment.commitment.messages.last_result_message_hash\n in\n fail_unless\n Tx_rollup_message_result_hash_repr.(agreed = expected)\n (Wrong_rejection_hash\n {provided = agreed; expected = `Hash expected})\n >>=? fun () -> return ctxt\n | None -> (\n match Tx_rollup_state_repr.last_removed_commitment_hashes state with\n | Some (last_hash, _) ->\n fail_unless\n Tx_rollup_message_result_hash_repr.(agreed = last_hash)\n (Wrong_rejection_hash\n {provided = agreed; expected = `Hash last_hash})\n >>=? fun () -> return ctxt\n | None -> tzfail (Internal_error \"Missing commitment predecessor\")))\n else\n check_message_result\n ctxt\n commitment\n (`Result agreed_result)\n ~path:agreed_result_path\n ~index:(disputed_position - 1)\n >>?= fun ctxt -> return ctxt\n\nlet reject_commitment ctxt rollup state level =\n Tx_rollup_state_repr.check_level_can_be_rejected state level >>?= fun () ->\n (* Fetching the next predecessor hash to be used *)\n (match Tx_rollup_level_repr.pred level with\n | Some pred_level ->\n find ctxt rollup state pred_level >>=? fun (ctxt, pred_commitment) ->\n let pred_hash =\n Option.map\n (fun (x : Submitted_commitment.t) -> x.commitment_hash)\n pred_commitment\n in\n return (ctxt, pred_hash)\n | None -> return (ctxt, None))\n (* We record in the state *)\n >>=? fun (ctxt, pred_hash) ->\n Tx_rollup_state_repr.record_commitment_rejection state level pred_hash\n >>?= fun state -> return (ctxt, state)\n" ;
} ;
{ name = "Tx_rollup_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** [originate context] originates a new tx rollup and returns its hash\n generated from the [origination_nonce] in context. It also increment the\n [origination_nonce]. *)\nval originate :\n Raw_context.t -> (Raw_context.t * Tx_rollup_repr.t) tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nlet fresh_tx_rollup_from_current_nonce ctxt =\n Raw_context.increment_origination_nonce ctxt >|? fun (ctxt, nonce) ->\n (ctxt, Tx_rollup_repr.originated_tx_rollup nonce)\n\nlet originate ctxt =\n fresh_tx_rollup_from_current_nonce ctxt >>?= fun (ctxt, tx_rollup) ->\n Tx_rollup_state_storage.init ctxt tx_rollup >|=? fun ctxt -> (ctxt, tx_rollup)\n" ;
} ;
{ name = "Sc_rollup_staker_index_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Sc_rollup_staker_index_repr\n\n(** [init ctxt rollup] initialize a staker index counter for [rollup]. *)\nval init : Raw_context.t -> Sc_rollup_repr.t -> Raw_context.t tzresult Lwt.t\n\n(** [fresh_staker_index ctxt rollup staker] creates a new index for [staker] and\n store it in {!Storage.Sc_rollup.Staker_index}. *)\nval fresh_staker_index :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Signature.public_key_hash ->\n (Raw_context.t * t) tzresult Lwt.t\n\n(** [find_staker_index_unsafe ctxt rollup staker] returns the index for the\n [rollup]'s [staker]. This function *must* be called only after they have\n checked for the existence of the rollup, and therefore it is not necessary\n for it to check for the existence of the rollup again. Otherwise, use the\n safe function {!find_staker_index}. *)\nval find_staker_index_unsafe :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Signature.public_key_hash ->\n (Raw_context.t * t option) tzresult Lwt.t\n\n(** Same as {!find_staker_index_unsafe} but fails if the value is absent. *)\nval get_staker_index_unsafe :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Signature.public_key_hash ->\n (Raw_context.t * t) tzresult Lwt.t\n\n(** [remove_staker ctxt rollup staker] cleans every storage associated\n to [staker] and it's index.\n The staker will be no longer considered active until a new index is given\n to it, through a new call to {!fresh_staker_index}. *)\nval remove_staker :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Signature.public_key_hash ->\n Raw_context.t tzresult Lwt.t\n\n(** [list_stakers_uncarbonated ctxt rollup] lists the active stakers on\n [rollup]. *)\nval list_stakers_uncarbonated :\n Raw_context.t -> Sc_rollup_repr.t -> Signature.public_key_hash list Lwt.t\n\n(** [is_active ctxt rollup staker_index] returns true iff [staker_index]\n is an active staker. *)\nval is_active :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n t ->\n (Raw_context.t * bool) tzresult Lwt.t\n\n(** [is_staker context rollup staker] returns [true] iff [staker] has a\n deposit on the given [rollup]. *)\nval is_staker :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Sc_rollup_repr.Staker.t ->\n (Raw_context.t * bool) tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Sc_rollup_errors\n\nlet init ctxt rollup =\n Storage.Sc_rollup.Staker_index_counter.init\n (ctxt, rollup)\n Sc_rollup_staker_index_repr.zero\n\nlet fresh_staker_index ctxt rollup staker =\n let open Lwt_result_syntax in\n (* This is safe because this storage is initialized at the rollup creation\n in {!Sc_rollup_storage.originate} .*)\n let* staker_index =\n Storage.Sc_rollup.Staker_index_counter.get (ctxt, rollup)\n in\n let* ctxt =\n Storage.Sc_rollup.Staker_index_counter.update\n (ctxt, rollup)\n (Sc_rollup_staker_index_repr.succ staker_index)\n in\n let* ctxt, _size =\n Storage.Sc_rollup.Staker_index.init (ctxt, rollup) staker staker_index\n in\n let* ctxt, _size_diff =\n Storage.Sc_rollup.Stakers.init\n (ctxt, rollup)\n staker_index\n Raw_level_repr.root\n in\n return (ctxt, staker_index)\n\nlet find_staker_index_unsafe ctxt rollup staker =\n Storage.Sc_rollup.Staker_index.find (ctxt, rollup) staker\n\nlet get_staker_index_unsafe ctxt rollup staker =\n let open Lwt_result_syntax in\n let* ctxt, staker_index_opt = find_staker_index_unsafe ctxt rollup staker in\n match staker_index_opt with\n | None -> tzfail Sc_rollup_not_staked\n | Some staker_index -> return (ctxt, staker_index)\n\nlet remove_staker ctxt rollup staker =\n let open Lwt_result_syntax in\n let* ctxt, staker_index = get_staker_index_unsafe ctxt rollup staker in\n let* ctxt, _size_diff =\n Storage.Sc_rollup.Staker_index.remove_existing (ctxt, rollup) staker\n in\n let* ctxt, _size_diff =\n Storage.Sc_rollup.Stakers.remove_existing (ctxt, rollup) staker_index\n in\n return ctxt\n\nlet list_stakers_uncarbonated ctxt rollup =\n Storage.Sc_rollup.Staker_index.keys_unaccounted (ctxt, rollup)\n\nlet is_active ctxt rollup staker_index =\n Storage.Sc_rollup.Stakers.mem (ctxt, rollup) staker_index\n\nlet is_staker ctxt rollup staker =\n Storage.Sc_rollup.Staker_index.mem (ctxt, rollup) staker\n" ;
} ;
{ name = "Sc_rollup_commitment_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 TriliTech <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Defines storage for Smart Contract Optimistic Rollups.\n\n {2 Commitments}\n\n [Commitment]s are stored directly in the L1 context. Commitments are\n immutable and content-addressed, and can be indexed by a [Commitment_hash].\n\n A commitment represents a claim about the state of a PVM.\n\n We also keep auxiliary state about each commitment, namely:\n\n {ul\n {li When it was first added.}\n {li Its current number of stakers.}\n }\n\n This auxiliary data is not part of the commitment itself. They represent\n information that the L1 knows about the claim, not the claim itself.\n\n {3 Predecessors and Boot state}\n Each commitment contains the hash of its {i predecessor}. Multiple\n commitments can have the same predecessor. Therefore, commitments form\n a Merkle tree.\n\n Conceptually the root of this tree is the [Commitment_hash.zero]. This\n commitment claims that the PVM (Proof-generating Virtual Machine) is in a\n pre-boot state and waiting to start booting by interpreting the boot sector with\n respect to the Machine semantics.\n\n {3 Cemented and Disputable commitments}\n Commitments accepted as true by the protocol are referred to as Cemented.\n A commitment that is not cemented is said to be disputable.\n\n {3 Stakers}\n The Stakers table maps Stakers (implicit accounts) to commitments hashes.\n\n Let [Stakers(S)] mean \"looking up the key S in [Stakers]\".\n\n A staker [S] is directly staked on [C] if [Stakers(S) = C]. A staker [S]\n is indirectly staked on [C] if [C] is an ancestor of [Stakers(S)] in the commitment tree.\n\n {3 Dispute}\n Commitments that have at least one sibling are referred to as Disputed.\n More formally, a commitment C is disputed if at least one staker is not\n (directly or indirectly) staked on C.\n\n {3 Dispute resolution}\n The rollup protocol ensures that all disputes are resolved before cementing\n a commitment. Therefore, cemented commitments form a list rather than a tree.\n\n In the context we only store the Last Cemented Commitment (LCC), which is\n by definition a descendant of [zero]. We also store all Disputable\n commitments that have at least one Staker.\n\n For example, assuming the full set of commitments for a rollup\n looks like this:\n\n {[\n LCC staker1 staker2\n | | |\n | V |\n V --c3 |\n zero--c1 --c2--/ |\n \\ V\n --c4------ c5\n ]}\n then commitments [c2..c5] will be stored in the context.\n\n {3 Conflicts}\n\n Let Commitments(S) be the set of commitments directly staked on by staker S.\n\n Two stakers A and B are:\n\n {ul\n {li In total agreement iff Commitments(A) = Commitments(B).}\n {li In partial agreement iff either Commitments(A) \226\138\130 Commitments(B), or\n Commitments(B) \226\138\130 Commitments(A).}\n {li In conflict iff they are neither in total or partial agreement.}}\n\n We can further refine a conflict to note what they are in conflict about,\n e.g. they may be in conflict about the inbox, about execution, or both. We\n can resolve conflicts by first resolving the conflict about inbox, then\n about execution (since execution is irrelevant if the inbox is not\n correct).\n *)\n\nmodule Commitment = Sc_rollup_commitment_repr\nmodule Commitment_hash = Commitment.Hash\n\n(** [last_cemented_commitment context rollup] returns the last cemented\n commitment of the rollup.\n\n If no commitments have been cemented, the rollup is said to be in a\n pre-boot state, and [last_cemented_commitment = Commitment_hash.zero].\n\n May fail with:\n {ul\n {li [Sc_rollup_does_not_exist] if [rollup] does not exist}} *)\nval last_cemented_commitment :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n (Commitment_hash.t * Raw_context.t) tzresult Lwt.t\n\n(** [last_cemented_commitment_hash_with_level ctxt sc_rollup] returns the hash\n and level of the last cemented commitment (lcc) for [sc_rollup]. If the\n rollup exists but no lcc exists, the initial commitment\n [Sc_rollup.Commitment.zero] together with the rollup origination level is\n returned.\n\n May fail with:\n {ul\n {li [Sc_rollup_does_not_exist] if [rollup] does not exist}}\n*)\nval last_cemented_commitment_hash_with_level :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n (Commitment_hash.t * Raw_level_repr.t * Raw_context.t) tzresult Lwt.t\n\n(** [get_commitment context rollup commitment_hash] returns the commitment with\n the given hash.\n\n May fail with:\n {ul\n {li [Sc_rollup_does_not_exist] if [rollup] does not exist}\n {li [Sc_rollup_unknown_commitment] if [commitment] does not exist}\n }\n*)\nval get_commitment :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Commitment_hash.t ->\n (Commitment.t * Raw_context.t) tzresult Lwt.t\n\n(** [get_commitment_opt_unsafe context rollup commitment_hash] returns an\n [Option.t] which is either a defined value containing the commitment with\n the given hash, or `None` if such a commitment does not exist. This\n function *must* be called only after they have checked for the existence\n of the rollup, and therefore it is not necessary for it to check for the\n existence of the rollup again. Otherwise, use the safe function\n {!get_commitment}.\n*)\nval get_commitment_opt_unsafe :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Commitment_hash.t ->\n (Commitment.t Option.t * Raw_context.t) tzresult Lwt.t\n\n(** [get_commitment_unsafe context rollup commitment_hash] returns the commitment\n with the given hash.\n This function *must* be called only after they have checked for the existence\n of the rollup, and therefore it is not necessary for it to check for the\n existence of the rollup again. Otherwise, use the safe function\n {!get_commitment}.\n\n May fail with:\n {ul\n {li [Sc_rollup_unknown_commitment] if [commitment] does not exist}\n }\n*)\nval get_commitment_unsafe :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Commitment_hash.t ->\n (Commitment.t * Raw_context.t) tzresult Lwt.t\n\n(** [set_commitment_added ctxt rollup node current] sets the commitment\n addition time of [node] to [current] iff the commitment time was\n not previously set, and leaves it unchanged otherwise.\n *)\nval set_commitment_added :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Commitment_hash.t ->\n Raw_level_repr.t ->\n (int * Raw_level_repr.t * Raw_context.t) tzresult Lwt.t\n\n(** [get_predecessor_opt_unsafe ctxt rollup commitment_hash] returns an\n [Option.t] value containing the [rollup] commitment predecessor of\n [commitment_hash] in the [ctxt], if any. It does not check for the\n existence of the [rollup]. *)\nval get_predecessor_opt_unsafe :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Commitment_hash.t ->\n (Commitment_hash.t Option.t * Raw_context.t) tzresult Lwt.t\n\n(** [get_predecessor_unsafe ctxt rollup commitment_hash] returns the [rollup]\n commitment predecessor of [commitment_hash] in the [ctxt]. It is unsafe\n as the current commitment is retrived using {!get_commitment_unsafe}.\n It does not check for the existence of the [rollup]. *)\nval get_predecessor_unsafe :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Commitment_hash.t ->\n (Commitment_hash.t * Raw_context.t) tzresult Lwt.t\n\n(** [check_if_commitments_are_related ~descendant ~ancestor] checks whether a\n commitment with hash [~ancestor] exists as a predecessor of [~descendant],\n among the list of commitments stored for [rollup] in [ctxt]. *)\nval check_if_commitments_are_related :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n descendant:Commitment_hash.t ->\n ancestor:Commitment_hash.t ->\n (bool * Raw_context.t) tzresult Lwt.t\n\n(** Hash a commitment and account for gas spent. *)\nval hash :\n Raw_context.t -> Commitment.t -> (Raw_context.t * Commitment_hash.t) tzresult\n\nmodule Internal_for_tests : sig\n (** [get_cemented_commitments_with_levels ctxt rollup] returns a list of all\n cemented commitment hashes and corresponding inbox levels that are present\n in the storage, ordered by inbox level.\n\n May fail with:\n {ul\n {li [Sc_rollup_does_not_exist] if [rollup] does not exist}\n }\n*)\n val get_cemented_commitments_with_levels :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n ((Commitment_hash.t * Raw_level_repr.t) list * Raw_context.t) tzresult Lwt.t\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 TriliTech <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Sc_rollup_errors\nmodule Store = Storage.Sc_rollup\nmodule Commitment = Sc_rollup_commitment_repr\nmodule Commitment_hash = Commitment.Hash\n\nlet get_commitment_opt_unsafe ctxt rollup commitment =\n let open Lwt_result_syntax in\n let* ctxt, res = Store.Commitments.find (ctxt, rollup) commitment in\n return (res, ctxt)\n\nlet get_commitment_unsafe ctxt rollup commitment =\n let open Lwt_result_syntax in\n let* res, ctxt = get_commitment_opt_unsafe ctxt rollup commitment in\n match res with\n | None -> tzfail (Sc_rollup_unknown_commitment commitment)\n | Some commitment -> return (commitment, ctxt)\n\nlet last_cemented_commitment ctxt rollup =\n let open Lwt_result_syntax in\n let* ctxt, res = Store.Last_cemented_commitment.find ctxt rollup in\n match res with\n | None -> tzfail (Sc_rollup_does_not_exist rollup)\n | Some lcc -> return (lcc, ctxt)\n\nlet get_commitment ctxt rollup commitment =\n let open Lwt_result_syntax in\n (* Assert that a last cemented commitment exists. *)\n let* _lcc, ctxt = last_cemented_commitment ctxt rollup in\n get_commitment_unsafe ctxt rollup commitment\n\nlet last_cemented_commitment_hash_with_level ctxt rollup =\n let open Lwt_result_syntax in\n let* commitment_hash, ctxt = last_cemented_commitment ctxt rollup in\n let+ {inbox_level; _}, ctxt =\n get_commitment_unsafe ctxt rollup commitment_hash\n in\n (commitment_hash, inbox_level, ctxt)\n\nlet set_commitment_added ctxt rollup node new_value =\n let open Lwt_result_syntax in\n let* ctxt, res = Store.Commitment_added.find (ctxt, rollup) node in\n match res with\n | Some old_value ->\n (* No need to re-add the read value *)\n return (0, old_value, ctxt)\n | None ->\n let* ctxt, size_diff, _was_bound =\n Store.Commitment_added.add (ctxt, rollup) node new_value\n in\n return (size_diff, new_value, ctxt)\n\nlet get_predecessor_opt_unsafe ctxt rollup node =\n let open Lwt_result_syntax in\n let* commitment, ctxt = get_commitment_opt_unsafe ctxt rollup node in\n return (Option.map (fun (c : Commitment.t) -> c.predecessor) commitment, ctxt)\n\nlet get_predecessor_unsafe ctxt rollup node =\n let open Lwt_result_syntax in\n let* commitment, ctxt = get_commitment_unsafe ctxt rollup node in\n return (commitment.predecessor, ctxt)\n\nlet check_if_commitments_are_related ctxt rollup ~descendant ~ancestor =\n let open Lwt_result_syntax in\n let rec aux ctxt current_commitment_hash =\n if Commitment_hash.(current_commitment_hash = ancestor) then\n return (true, ctxt)\n else\n let* predecessor_commitment_opt, ctxt =\n get_predecessor_opt_unsafe ctxt rollup current_commitment_hash\n in\n match predecessor_commitment_opt with\n | None -> return (false, ctxt)\n | Some cch -> (aux [@ocaml.tailcall]) ctxt cch\n in\n aux ctxt descendant\n\nlet hash ctxt commitment =\n let open Result_syntax in\n let* ctxt =\n Raw_context.consume_gas\n ctxt\n Sc_rollup_costs.Constants.cost_serialize_commitment\n in\n let commitment_bytes_opt =\n Data_encoding.Binary.to_bytes_opt\n Sc_rollup_commitment_repr.encoding\n commitment\n in\n let* commitment_bytes =\n Option.to_result\n ~none:(trace_of_error Sc_rollup_bad_commitment_serialization)\n commitment_bytes_opt\n in\n let bytes_len = Bytes.length commitment_bytes in\n let* ctxt =\n Raw_context.consume_gas ctxt (Sc_rollup_costs.cost_hash_bytes ~bytes_len)\n in\n return (ctxt, Sc_rollup_commitment_repr.Hash.hash_bytes [commitment_bytes])\n\nmodule Internal_for_tests = struct\n let get_cemented_commitments_with_levels ctxt rollup =\n let open Lwt_result_syntax in\n let rec aux ctxt commitments_with_levels commitment_hash =\n let* commitment_opt, ctxt =\n get_commitment_opt_unsafe ctxt rollup commitment_hash\n in\n match commitment_opt with\n | None -> return (commitments_with_levels, ctxt)\n | Some {predecessor; inbox_level; _} ->\n (aux [@ocaml.tailcall])\n ctxt\n ((commitment_hash, inbox_level) :: commitments_with_levels)\n predecessor\n in\n let* lcc_hash, ctxt = last_cemented_commitment ctxt rollup in\n let+ commitments_with_levels, ctxt = aux ctxt [] lcc_hash in\n (commitments_with_levels, ctxt)\nend\n" ;
} ;
{ name = "Sc_rollup_outbox_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** A module for managing state concerning a rollup's outbox. *)\n\n(** [record_applied_message ctxt rollup level ~message_index] marks the message\n in the outbox of rollup [rollup] at level [level] and position\n [message_index] as processed. Returns the size diff resulting from adding an\n entry. The size diff may be 0 if an entry already exists, or negative if an\n index is replaced with a new level.\n\n An attempt to apply an old level that has already been replaced fails with\n an [Sc_rollup_outbox_level_expired] error.\n\n In case a message has already been applied for the given level and message\n index, the function fails with an [Sc_rollup_outbox_message_already_applied]\n error. *)\nval record_applied_message :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Raw_level_repr.t ->\n message_index:int ->\n (Z.t * Raw_context.t) tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 TriliTech <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nlet level_index ctxt level =\n let max_active_levels =\n Constants_storage.sc_rollup_max_active_outbox_levels ctxt\n in\n Int32.rem (Raw_level_repr.to_int32 level) max_active_levels\n\nlet record_applied_message ctxt rollup level ~message_index =\n let open Lwt_result_syntax in\n (* Check that the 0 <= message index < maximum number of outbox messages per\n level. *)\n let*? () =\n let max_outbox_messages_per_level =\n Constants_storage.sc_rollup_max_outbox_messages_per_level ctxt\n in\n error_unless\n Compare.Int.(\n 0 <= message_index && message_index < max_outbox_messages_per_level)\n Sc_rollup_errors.Sc_rollup_invalid_outbox_message_index\n in\n let level_index = level_index ctxt level in\n let* ctxt, level_and_bitset_opt =\n Storage.Sc_rollup.Applied_outbox_messages.find (ctxt, rollup) level_index\n in\n let*? bitset, ctxt =\n let open Result_syntax in\n let* bitset, ctxt =\n match level_and_bitset_opt with\n | Some (existing_level, bitset)\n when Raw_level_repr.(existing_level = level) ->\n (* The level at the index is the same as requested. Fail if the\n message has been applied already. *)\n let* already_applied = Bitset.mem bitset message_index in\n let* () =\n error_when\n already_applied\n Sc_rollup_errors.Sc_rollup_outbox_message_already_applied\n in\n return (bitset, ctxt)\n | Some (existing_level, _bitset)\n when Raw_level_repr.(level < existing_level) ->\n tzfail Sc_rollup_errors.Sc_rollup_outbox_level_expired\n | Some _ | None ->\n (* The old level is outdated or there is no previous bitset at\n this index. *)\n return (Bitset.empty, ctxt)\n in\n let* bitset = Bitset.add bitset message_index in\n return (bitset, ctxt)\n in\n let+ ctxt, size_diff, _is_new =\n Storage.Sc_rollup.Applied_outbox_messages.add\n (ctxt, rollup)\n level_index\n (level, bitset)\n in\n (Z.of_int size_diff, ctxt)\n" ;
} ;
{ name = "Sc_rollup_stake_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 TriliTech <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** [remove_staker context rollup staker] forcibly removes the given [staker]\n and confiscates their frozen deposits.\n\n Removes [staker] from the list of active stakers on the [rollup] and\n clean its metadata.\n*)\nval remove_staker :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Sc_rollup_repr.Staker.t ->\n (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t\n\n(** [publish_commitment context rollup staker commitment] published [commitment].\n\n Starts by depositing a stake for [staker] if [staker] is not a known\n staker of [rollup]. Then, [staker] will use its stake to stake on\n [commitment].\n\n For publishing to succeed, the following must hold:\n {ol\n {li A deposit exists (or can be deposited) for [staker].}\n {li The commitment respects the commitment period and is not published\n in advance.}\n {li The commitment is not past the curfew, i.e., stakers has a limit on the\n available time to publish, if a staker already published for this\n inbox level.}\n {li The [commitment.predecessor] exists.}\n {li The [commitment] contains at least one tick.}\n }\n\n Returns the hash of the given commitment, the level when the commitment\n was first published by some staker, the modified context and the balance\n updates if a stake was deposited.\n\n This function does not authenticate the staker.\n*)\nval publish_commitment :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Sc_rollup_repr.Staker.t ->\n Sc_rollup_commitment_repr.t ->\n (Sc_rollup_commitment_repr.Hash.t\n * Raw_level_repr.t\n * Raw_context.t\n * Receipt_repr.balance_updates)\n tzresult\n Lwt.t\n\n(** [cement_commitment context rollup commitment] cements the given\n commitment whose hash is given (and returns the corresponding commitment).\n\n For cementing to succeed, the following must hold:\n {ol\n {li The deadline for [commitment] must have passed.}\n {li The predecessor of [commitment] must be the Last Cemented Commitment.}\n {li There must be at least one staker.}\n {li All stakers must be indirectly staked on [commitment].}\n }\n\n If successful, Last Cemented commitment is set to the given [commitment],\n and deallocate the old cemented commitment accordingly to the number\n of stored cemented commitments.\n\n Clean the storage for the metadata added for this inbox level.\n*)\nval cement_commitment :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Sc_rollup_commitment_repr.Hash.t ->\n (Raw_context.t * Sc_rollup_commitment_repr.t) tzresult Lwt.t\n\n(** [find_staker context rollup staker] returns the most recent commitment\n [staker] staked on, or [None] if its last staked commitment is older\n or equal than the last cemented commitment. *)\nval find_staker :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Sc_rollup_repr.Staker.t ->\n (Raw_context.t * Sc_rollup_commitment_repr.Hash.t option) tzresult Lwt.t\n\n(** [is_staked_on context rollup staker commitment_hash] returns true\n iff [staker] is an active staker and has staked on [commitment_hash]. *)\nval is_staked_on :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Sc_rollup_repr.Staker.t ->\n Sc_rollup_commitment_repr.Hash.t ->\n (Raw_context.t * bool) tzresult Lwt.t\n\n(** [commitments_uncarbonated ctxt ~rollup ~inbox_level] returns the\n list of commitments associated to [rollup] at [inbox_level] *)\nval commitments_uncarbonated :\n Raw_context.t ->\n rollup:Sc_rollup_repr.t ->\n inbox_level:Raw_level_repr.t ->\n Sc_rollup_commitment_repr.Hash.t list option tzresult Lwt.t\n\n(** [stakers_ids_uncarbonated ctxt ~rollup ~commitment] returns the\n list of stakers' indexes associated to [rollup] for a specific\n [commitment] *)\nval stakers_ids_uncarbonated :\n Raw_context.t ->\n rollup:Sc_rollup_repr.t ->\n commitment:Sc_rollup_commitment_repr.Hash.t ->\n Sc_rollup_staker_index_repr.t list tzresult Lwt.t\n\n(** [staker_id_uncarbonated ctxt ~rollup ~pkh] returns the staker's\n index associated to the public key hash [pkh] *)\nval staker_id_uncarbonated :\n Raw_context.t ->\n rollup:Sc_rollup_repr.t ->\n pkh:Signature.public_key_hash ->\n Sc_rollup_staker_index_repr.t tzresult Lwt.t\n\n(** [stakers_pkhs_uncarbonated ctxt ~rollup] returns the public key hashes \n of stakers that are currently actively staking on [rollup] *)\nval stakers_pkhs_uncarbonated :\n Raw_context.t ->\n rollup:Sc_rollup_repr.t ->\n Signature.public_key_hash list Lwt.t\n\n(** [withdraw_stake context rollup staker] removes [staker] and cleans\n its metadata. [staker] is allowed to withdraw if it latest staked\n commitment is older than the last cemented commitment.\n*)\nval withdraw_stake :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Sc_rollup_repr.Staker.t ->\n (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t\n\n(** [commitments_of_inbox_level ctxt rollup inbox_level] returns the list\n of commitments for [inbox_level]. *)\nval commitments_of_inbox_level :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Raw_level_repr.t ->\n (Raw_context.t * Sc_rollup_commitment_repr.Hash.t list) tzresult Lwt.t\n\n(** [stakers_of_commitment ctxt rollup commitment_hash] returns the list\n of stakers staking on [commitment_hash]. *)\nval stakers_of_commitment :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Sc_rollup_commitment_repr.Hash.t ->\n (Raw_context.t * Sc_rollup_staker_index_repr.t list) tzresult Lwt.t\n\n(** [find_commitment_of_staker_in_commitments ctxt rollup staker_index commitments]\n selects in [commitments] the hash of the commitment staked by\n [staker_index], if any. *)\nval find_commitment_of_staker_in_commitments :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Sc_rollup_staker_index_repr.t ->\n Sc_rollup_commitment_repr.Hash.t list ->\n (Raw_context.t * Sc_rollup_commitment_repr.Hash.t option) tzresult Lwt.t\n\n(**/**)\n\nmodule Internal_for_tests : sig\n (** [deposit_stake context rollup staker] stakes [staker] on the [rollup] by\n freezing [sc_rollup_stake_amount] from [staker]'s account balance and\n initializing [staker]'s metadata.\n\n This should usually be followed by [refine_stake] to stake on a\n specific commitment.\n\n Returns the modified context, the balance updates of the frozen\n deposit and the index created for [staker].\n *)\n val deposit_stake :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Sc_rollup_repr.Staker.t ->\n (Raw_context.t\n * Receipt_repr.balance_updates\n * Sc_rollup_staker_index_repr.t)\n tzresult\n Lwt.t\n\n (** [refine_stake context rollup commitment staker] makes [staker]\n stakes on [commitment].\n\n Because we do not assume any form of coordination between validators, we\n do not distinguish between {i adding new} commitments and {i staking on\n existing commitments}. The storage of commitments is content-addressable\n to minimize storage duplication.\n\n The first time a commitment hash is staked on, it is assigned a deadline,\n which is counted in Tezos blocks (levels). Further stakes on the block does\n not affect the deadline. The commitment can not be cemented before the\n deadline has expired. Note that if a commitment is removed due to disputes\n and then re-entered, a later deadline may be assigned. Assuming one honest\n staker is always available, this only affects invalid commitments.\n\n See {!publish_commitment} to see the list of properties this function\n enforces.\n\n Returns the hashed commitment, at the first level this commitment was\n published, and the modified context.\n *)\n val refine_stake :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Sc_rollup_repr.Staker.t ->\n Sc_rollup_commitment_repr.t ->\n (Sc_rollup_commitment_repr.Hash.t * Raw_level_repr.t * Raw_context.t)\n tzresult\n Lwt.t\n\n (** The maximum storage size requirement (in bytes) of a commitment *)\n val max_commitment_storage_size_in_bytes : int\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 TriliTech <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Sc_rollup_errors\nmodule Store = Storage.Sc_rollup\nmodule Commitment_storage = Sc_rollup_commitment_storage\nmodule Commitment = Sc_rollup_commitment_repr\nmodule Commitment_hash = Commitment.Hash\n\n(** As the sets encoded with a list are proportional to the number of\n stakers on the rollup, we admit that it will be a small set. We\n also admit that a small list respecting the set properties is more\n efficient than using a real {!Set.S}. *)\nmodule Set_out_of_list (S : sig\n type t := Raw_context.t * Sc_rollup_repr.t\n\n type key\n\n type value\n\n val equal_value : value -> value -> bool\n\n val find : t -> key -> (Raw_context.t * value list option) tzresult Lwt.t\n\n val add :\n t -> key -> value list -> (Raw_context.t * int * bool) tzresult Lwt.t\n\n val remove : t -> key -> (Raw_context.t * int) tzresult Lwt.t\nend) =\nstruct\n let find ctxt rollup key = S.find (ctxt, rollup) key\n\n let get ctxt rollup key =\n let open Lwt_result_syntax in\n let* ctxt, values_opt = find ctxt rollup key in\n return (ctxt, Option.value ~default:[] values_opt)\n\n let remove ctxt rollup key = S.remove (ctxt, rollup) key\n\n let mem ctxt rollup key value =\n let open Lwt_result_syntax in\n let* ctxt, values = get ctxt rollup key in\n let exists = List.mem ~equal:S.equal_value value values in\n return (ctxt, exists)\n\n let add ctxt rollup key value =\n let open Lwt_result_syntax in\n let* ctxt, existing_values = get ctxt rollup key in\n let exists = List.mem ~equal:S.equal_value value existing_values in\n if exists then return (ctxt, 0, existing_values)\n else\n let values = value :: existing_values in\n let* ctxt, diff_size, _existed = S.add (ctxt, rollup) key values in\n return (ctxt, diff_size, values)\nend\n\nmodule Commitments_per_inbox_level = Set_out_of_list (struct\n type key = Raw_level_repr.t\n\n type value = Commitment_hash.t\n\n let equal_value = Commitment_hash.equal\n\n let find = Store.Commitments_per_inbox_level.find\n\n let add = Store.Commitments_per_inbox_level.add\n\n let remove = Store.Commitments_per_inbox_level.remove_existing\nend)\n\nmodule Commitment_stakers = Set_out_of_list (struct\n type key = Commitment_hash.t\n\n type value = Sc_rollup_staker_index_repr.t\n\n let equal_value = Sc_rollup_staker_index_repr.equal\n\n let find = Store.Commitment_stakers.find\n\n let add = Store.Commitment_stakers.add\n\n let remove = Store.Commitment_stakers.remove_existing\nend)\n\n(* Looks for the commitment [staker] is staking on, in the list of commitments\n posted for this level. *)\nlet rec find_commitment_of_staker_in_commitments ctxt rollup staker_index =\n let open Lwt_result_syntax in\n function\n | [] -> return (ctxt, None)\n | commitment_hash :: rst ->\n let* ctxt, exists =\n Commitment_stakers.mem ctxt rollup commitment_hash staker_index\n in\n if exists then return (ctxt, Some commitment_hash)\n else find_commitment_of_staker_in_commitments ctxt rollup staker_index rst\n\nlet get_commitment_of_staker_in_commitments ctxt rollup staker_index commitments\n =\n let open Lwt_result_syntax in\n let* ctxt, opt =\n find_commitment_of_staker_in_commitments\n ctxt\n rollup\n staker_index\n commitments\n in\n match opt with\n | Some res -> return (ctxt, res)\n | None -> tzfail Sc_rollup_not_staked\n\nlet find_staker ctxt rollup staker =\n let open Lwt_result_syntax in\n let* ctxt, staker_index =\n Sc_rollup_staker_index_storage.get_staker_index_unsafe ctxt rollup staker\n in\n let* ctxt, level = Store.Stakers.get (ctxt, rollup) staker_index in\n let* ctxt, commitments_opt =\n Commitments_per_inbox_level.find ctxt rollup level\n in\n match commitments_opt with\n | None ->\n (* The staked commitment is no longer active (i.e. cemented). *)\n return (ctxt, None)\n | Some commitments ->\n let+ ctxt, commitment_hash =\n get_commitment_of_staker_in_commitments\n ctxt\n rollup\n staker_index\n commitments\n in\n (ctxt, Some commitment_hash)\n\nlet commitments_uncarbonated ctxt ~rollup ~inbox_level =\n let open Lwt_result_syntax in\n let* _, commitments =\n Commitments_per_inbox_level.find ctxt rollup inbox_level\n in\n return commitments\n\nlet stakers_ids_uncarbonated ctxt ~rollup ~commitment =\n let open Lwt_result_syntax in\n let* _, stakers_ids =\n Store.Commitment_stakers.get (ctxt, rollup) commitment\n in\n return stakers_ids\n\nlet staker_id_uncarbonated ctxt ~rollup ~pkh =\n let open Lwt_result_syntax in\n let* _, staker_index = Store.Staker_index.get (ctxt, rollup) pkh in\n return staker_index\n\nlet stakers_pkhs_uncarbonated ctxt ~rollup =\n Sc_rollup_staker_index_storage.list_stakers_uncarbonated ctxt rollup\n\nlet get_contract_and_stake ctxt staker =\n let staker_contract = Contract_repr.Implicit staker in\n let stake = Constants_storage.sc_rollup_stake_amount ctxt in\n (staker_contract, stake)\n\n(** [assert_staked_on_lcc_or_ancestor ctxt rollup ~staker_index lcc_inbox_level]\n fails unless the most recent commitment [staker_index] has staked\n is older than [lcc_inbox_level]. This is a necessary condition to\n withdraw a staker's bond. *)\nlet assert_staked_on_lcc_or_ancestor ctxt rollup ~staker_index lcc_inbox_level =\n let open Lwt_result_syntax in\n let* ctxt, last_staked_level =\n Store.Stakers.get (ctxt, rollup) staker_index\n in\n let* () =\n fail_unless\n Raw_level_repr.(last_staked_level <= lcc_inbox_level)\n Sc_rollup_not_staked_on_lcc_or_ancestor\n in\n return ctxt\n\nlet deposit_stake ctxt rollup staker =\n let open Lwt_result_syntax in\n (* Freeze the stake of [staker]. *)\n let staker_contract, stake = get_contract_and_stake ctxt staker in\n let* ctxt, staker_balance =\n Contract_storage.get_balance_carbonated ctxt staker_contract\n in\n let bond_id = Bond_id_repr.Sc_rollup_bond_id rollup in\n let* ctxt, balance_updates =\n trace\n (Sc_rollup_staker_funds_too_low\n {\n staker;\n sc_rollup = rollup;\n staker_balance;\n min_expected_balance = stake;\n })\n @@ Token.transfer\n ctxt\n (`Contract staker_contract)\n (`Frozen_bonds (staker_contract, bond_id))\n stake\n in\n (* Initialize the index of [staker]. *)\n let* ctxt, staker_index =\n Sc_rollup_staker_index_storage.fresh_staker_index ctxt rollup staker\n in\n return (ctxt, balance_updates, staker_index)\n\nlet withdraw_stake ctxt rollup staker =\n let open Lwt_result_syntax in\n let* _lcc, lcc_inbox_level, ctxt =\n Commitment_storage.last_cemented_commitment_hash_with_level ctxt rollup\n in\n let* ctxt, staker_index =\n Sc_rollup_staker_index_storage.get_staker_index_unsafe ctxt rollup staker\n in\n let* ctxt =\n assert_staked_on_lcc_or_ancestor ctxt rollup ~staker_index lcc_inbox_level\n in\n let staker_contract, stake = get_contract_and_stake ctxt staker in\n let bond_id = Bond_id_repr.Sc_rollup_bond_id rollup in\n let* ctxt, balance_updates =\n Token.transfer\n ctxt\n (`Frozen_bonds (staker_contract, bond_id))\n (`Contract staker_contract)\n stake\n in\n let* ctxt = Sc_rollup_staker_index_storage.remove_staker ctxt rollup staker in\n return (ctxt, balance_updates)\n\nlet assert_commitment_not_too_far_ahead ctxt rollup lcc commitment =\n let open Lwt_result_syntax in\n let* lcc, ctxt = Commitment_storage.get_commitment_unsafe ctxt rollup lcc in\n let min_level = Commitment.(lcc.inbox_level) in\n let max_level = Commitment.(commitment.inbox_level) in\n let* () =\n fail_when\n (let sc_rollup_max_lookahead =\n Constants_storage.sc_rollup_max_lookahead_in_blocks ctxt\n in\n Compare.Int32.(\n sc_rollup_max_lookahead < Raw_level_repr.diff max_level min_level))\n Sc_rollup_too_far_ahead\n in\n return ctxt\n\n(** Enfore that a commitment's inbox level increases by an exact fixed\n amount over its predecessor. This property is used in several\n places - not obeying it causes severe breakage. *)\nlet assert_commitment_period ctxt rollup commitment =\n let open Lwt_result_syntax in\n let pred_hash = Commitment.(commitment.predecessor) in\n let* pred, ctxt =\n Commitment_storage.get_commitment_unsafe ctxt rollup pred_hash\n in\n let pred_level = Commitment.(pred.inbox_level) in\n (* Commitments needs to be posted for inbox levels every [commitment_period].\n Therefore, [commitment.inbox_level] must be\n [predecessor_commitment.inbox_level + commitment_period]. *)\n let sc_rollup_commitment_period =\n Constants_storage.sc_rollup_commitment_period_in_blocks ctxt\n in\n let* () =\n fail_unless\n Raw_level_repr.(\n commitment.inbox_level = add pred_level sc_rollup_commitment_period)\n Sc_rollup_bad_inbox_level\n in\n return ctxt\n\n(** [assert_commitment_is_not_past_curfew ctxt rollup inbox_level]\n will look in the storage [Commitment_first_publication_level] for\n the level of the oldest commit for [inbox_level] and if it is more\n than [sc_rollup_challenge_window_in_blocks] ago it fails with\n [Sc_rollup_commitment_past_curfew]. Otherwise it adds the\n respective storage (if it is not set) and returns the context. *)\nlet assert_commitment_is_not_past_curfew ctxt rollup inbox_level =\n let open Lwt_result_syntax in\n let current_level = (Raw_context.current_level ctxt).level in\n let* ctxt, oldest_commit =\n Store.Commitment_first_publication_level.find (ctxt, rollup) inbox_level\n in\n match oldest_commit with\n | Some oldest_commit ->\n let refutation_deadline_blocks =\n Int32.of_int\n @@ Constants_storage.sc_rollup_challenge_window_in_blocks ctxt\n in\n if\n Compare.Int32.(\n Raw_level_repr.diff current_level oldest_commit\n > refutation_deadline_blocks)\n then tzfail Sc_rollup_commitment_past_curfew\n else return (ctxt, 0)\n | None ->\n (* The storage cost is covered by the stake. *)\n let* ctxt, size_diff, _existed =\n Store.Commitment_first_publication_level.add\n (ctxt, rollup)\n inbox_level\n current_level\n in\n return (ctxt, size_diff)\n\n(** Check invariants on [inbox_level], enforcing overallocation of storage,\n regularity of block production and curfew.\n\n The constants used by [assert_refine_conditions_met] must be chosen such\n that the maximum cost of storage allocated by each staker is at most the size\n of their deposit.\n *)\nlet assert_refine_conditions_met ~current_level ~lcc_inbox_level ctxt rollup lcc\n commitment =\n let open Lwt_result_syntax in\n let commitment_inbox_level = commitment.Commitment.inbox_level in\n let* () =\n fail_unless\n Raw_level_repr.(commitment_inbox_level > lcc_inbox_level)\n (Sc_rollup_commitment_too_old\n {last_cemented_inbox_level = lcc_inbox_level; commitment_inbox_level})\n in\n let* ctxt = assert_commitment_not_too_far_ahead ctxt rollup lcc commitment in\n let* ctxt = assert_commitment_period ctxt rollup commitment in\n let* ctxt, size_diff =\n assert_commitment_is_not_past_curfew\n ctxt\n rollup\n Commitment.(commitment.inbox_level)\n in\n let* () =\n fail_unless\n Raw_level_repr.(commitment_inbox_level < current_level)\n (Sc_rollup_commitment_from_future\n {current_level; inbox_level = commitment.inbox_level})\n in\n return (ctxt, size_diff)\n\nlet is_staked_on ctxt rollup staker commitment_hash =\n let open Lwt_result_syntax in\n let* ctxt, staker_index_opt =\n Sc_rollup_staker_index_storage.find_staker_index_unsafe ctxt rollup staker\n in\n match staker_index_opt with\n | None -> return (ctxt, false)\n | Some staker_index ->\n Commitment_stakers.mem ctxt rollup commitment_hash staker_index\n\nlet deallocate_commitment_contents ctxt rollup commitment_hash =\n let open Lwt_result_syntax in\n let* ctxt, _size_freed =\n Store.Commitments.remove_existing (ctxt, rollup) commitment_hash\n in\n return ctxt\n\nlet deallocate_commitment_metadata ctxt rollup commitment_hash =\n let open Lwt_result_syntax in\n let* ctxt, _size_freed =\n Store.Commitment_added.remove_existing (ctxt, rollup) commitment_hash\n in\n return ctxt\n\nlet deallocate_commitment ctxt rollup commitment_hash =\n let open Lwt_result_syntax in\n let* ctxt = deallocate_commitment_metadata ctxt rollup commitment_hash in\n deallocate_commitment_contents ctxt rollup commitment_hash\n\nlet find_commitment_to_deallocate ctxt rollup commitment_hash =\n let open Lwt_result_syntax in\n (* The recursion is safe as long as [num_commitments_to_keep] remains\n a small value. *)\n let rec aux ctxt commitment_hash n =\n if Compare.Int.(n = 0) then return (Some commitment_hash, ctxt)\n else\n let* pred_hash, ctxt =\n Commitment_storage.get_predecessor_opt_unsafe\n ctxt\n rollup\n commitment_hash\n in\n match pred_hash with\n | None -> return (None, ctxt)\n | Some pred_hash -> (aux [@ocaml.tailcall]) ctxt pred_hash (n - 1)\n in\n (* We must not remove the commitment itself as we need it to allow\n executing outbox messages for a limited period. The maximum number of\n active cemented commitments available for execution is specified in\n [ctxt.sc_rollup.max_number_of_stored_cemented_commitments].\n Instead, we remove the oldest cemented commitment that would exceed\n [max_number_of_cemented_commitments], if such exist.\n\n Decrease max_number_of_stored_cemented_commitments by one because\n we start counting commitments from old_lcc, rather than from new_lcc.\n *)\n let num_commitments_to_keep =\n (Raw_context.constants ctxt).sc_rollup\n .max_number_of_stored_cemented_commitments - 1\n in\n aux ctxt commitment_hash num_commitments_to_keep\n\n(* Maximum storage size in bytes allocated during a {!refine_stake}.\n The first commitment of a inbox_level allocates the most bytes,\n subsequent commitments for the same level may cost less (e.g. same\n commitment published).\n\n We are looking to assert that the most possible bytes allocated in the\n storage is covered by the deposit.\n\n Maximum value computed and observed:\n - Commitment_first_publication_level: 4\n - Commitments: 77\n - Commitments_added: 4\n - Stakers: 4\n - Commitments_per_inbox_level: 36\n - Commitment_stakers is variable but should not exceed 10 bytes\n\n That is, 125 bytes are fixed.\n\n The variable comes from the {!Sc_rollup_staker_index.encoding}. Although,\n the index of the 10^9-th stakers is 6 bytes, 10 bytes as an over-approxiamtion\n should be fine (10 bytes also accounts for the list's overhead encoding).\n*)\nlet max_commitment_storage_size_in_bytes = 125 + 10\n\n(** [set_staker_commitment ctxt rollup staker_index inbox_level commitment_hash]\n updates the **latest** commitment [staker_index] stakes on.\n Adds [staker_index] to the set of stakers staking on [commitment_hash]. *)\nlet set_staker_commitment ctxt rollup staker_index inbox_level commitment_hash =\n let open Lwt_result_syntax in\n (* Update the latest commitment [staker_index] stakes on. *)\n let* ctxt, size_diff_stakers =\n let* ctxt, last_level = Store.Stakers.get (ctxt, rollup) staker_index in\n if Raw_level_repr.(last_level < inbox_level) then\n Store.Stakers.update (ctxt, rollup) staker_index inbox_level\n else return (ctxt, 0)\n in\n (* Adds [staker_index] to the set of stakers staking on [commitment_hash]. *)\n let* ctxt, size_diff_commitment_stakers, _stakers =\n Commitment_stakers.add ctxt rollup commitment_hash staker_index\n in\n return (ctxt, size_diff_stakers + size_diff_commitment_stakers)\n\n(** [assert_staker_dont_double_stake ctxt rollup staker_index commitments]\n asserts that [staker_index] do not stake on multiple commitments in\n [commitments]. *)\nlet assert_staker_dont_double_stake ctxt rollup staker_index commitments =\n let open Lwt_result_syntax in\n (* Compute the list of commitments [staker_index] stakes on. *)\n let* ctxt, staked_on_commitments =\n List.fold_left_es\n (fun (ctxt, staked_on_commitments) commitment ->\n let* ctxt, is_staked_on =\n Commitment_stakers.mem ctxt rollup commitment staker_index\n in\n if is_staked_on then return (ctxt, commitment :: staked_on_commitments)\n else return (ctxt, staked_on_commitments))\n (ctxt, [])\n commitments\n in\n let* () =\n fail_when\n Compare.List_length_with.(staked_on_commitments > 1)\n Sc_rollup_errors.Sc_rollup_staker_double_stake\n in\n return ctxt\n\n(* TODO: https://gitlab.com/tezos/tezos/-/issues/2559\n Add a test checking that L2 nodes can catch up after going offline. *)\nlet refine_stake ctxt rollup commitment ~staker_index ~lcc ~lcc_inbox_level =\n let open Lwt_result_syntax in\n let publication_level = (Raw_context.current_level ctxt).level in\n (* Checks the commitment validity, see {!assert_refine_conditions_met}. *)\n let* ctxt, refine_conditions_size_diff =\n assert_refine_conditions_met\n ctxt\n rollup\n lcc\n commitment\n ~current_level:publication_level\n ~lcc_inbox_level\n in\n let*? ctxt, commitment_hash =\n Sc_rollup_commitment_storage.hash ctxt commitment\n in\n (* Adds the commitment to the storage. *)\n let* ctxt, commitment_size_diff, _commit_existed =\n Store.Commitments.add (ctxt, rollup) commitment_hash commitment\n in\n (* Initializes or fetches the level at which the commitment was first\n published. *)\n let* commitment_added_size_diff, commitment_added_level, ctxt =\n Commitment_storage.set_commitment_added\n ctxt\n rollup\n commitment_hash\n publication_level\n in\n (* Updates the [staker_index]'s metadata. *)\n let* ctxt, set_staker_commitment_size_diff =\n set_staker_commitment\n ctxt\n rollup\n staker_index\n commitment.inbox_level\n commitment_hash\n in\n (* Adds the [commitment] to the set of commitments for this inbox level. *)\n let* ctxt, commitments_per_inbox_level_size_diff, commitments =\n Commitments_per_inbox_level.add\n ctxt\n rollup\n commitment.inbox_level\n commitment_hash\n in\n (* Checks that the staker is not double staking, done at the end to avoid\n the double get to the list of commitments. *)\n let* ctxt =\n assert_staker_dont_double_stake ctxt rollup staker_index commitments\n in\n let total_size_diff =\n refine_conditions_size_diff + commitment_size_diff\n + commitment_added_size_diff + set_staker_commitment_size_diff\n + commitments_per_inbox_level_size_diff\n in\n return (commitment_hash, commitment_added_level, ctxt, total_size_diff)\n\nlet publish_commitment ctxt rollup staker commitment =\n let open Lwt_result_syntax in\n let* lcc, lcc_inbox_level, ctxt =\n Commitment_storage.last_cemented_commitment_hash_with_level ctxt rollup\n in\n let* () =\n fail_when\n Sc_rollup_repr.Number_of_ticks.(\n commitment.Commitment.number_of_ticks = zero)\n Sc_rollup_zero_tick_commitment\n in\n let* ctxt, staker_index_opt =\n Sc_rollup_staker_index_storage.find_staker_index_unsafe ctxt rollup staker\n in\n (* If [staker] is an active staker, it has an index. *)\n let* ctxt, balances_updates, staker_index =\n match staker_index_opt with\n | None -> deposit_stake ctxt rollup staker\n | Some staker_index -> return (ctxt, [], staker_index)\n in\n let* commitment_hash, publication_level, ctxt, _size_diff =\n refine_stake ctxt rollup ~staker_index commitment ~lcc ~lcc_inbox_level\n in\n return (commitment_hash, publication_level, ctxt, balances_updates)\n\n(** [active_stakers_index ctxt rollup stakers] filters [stakers] to return\n only the active ones. *)\nlet active_stakers_index ctxt rollup stakers =\n let open Lwt_result_syntax in\n List.fold_left_es\n (fun (ctxt, active_stakers_index) staker ->\n let* ctxt, is_staker_active =\n Sc_rollup_staker_index_storage.is_active ctxt rollup staker\n in\n if is_staker_active then return (ctxt, staker :: active_stakers_index)\n else return (ctxt, active_stakers_index))\n (ctxt, [])\n stakers\n\nlet is_cementable_candidate_commitment ctxt rollup lcc commitment_hash =\n let open Lwt_result_syntax in\n let* commitment, ctxt =\n Commitment_storage.get_commitment_unsafe ctxt rollup commitment_hash\n in\n if Commitment_hash.equal commitment.predecessor lcc then\n let* ctxt, stakers_on_commitment =\n Commitment_stakers.get ctxt rollup commitment_hash\n in\n let* ctxt, active_stakers_index =\n active_stakers_index ctxt rollup stakers_on_commitment\n in\n (* The commitment is active if its predecessor is the LCC and\n at least one active steaker has staked on it. *)\n return (ctxt, Compare.List_length_with.(active_stakers_index > 0))\n else (* Dangling commitment. *)\n return (ctxt, false)\n\nlet cementable_candidate_commitments_of_inbox_level ctxt rollup ~old_lcc\n ~new_lcc inbox_level =\n let open Lwt_result_syntax in\n let* ctxt, commitments =\n Commitments_per_inbox_level.get ctxt rollup inbox_level\n in\n match commitments with\n | [candidate_commitment] when Commitment_hash.(new_lcc = candidate_commitment)\n ->\n (* The check that [new_lcc.predecessor = old] is done by the caller.\n In 99.99% of cases there will be only one candidate commitment,\n we minimize the cost in this case. *)\n let* ctxt, stakers_on_commitment =\n Commitment_stakers.get ctxt rollup candidate_commitment\n in\n let* ctxt, active_stakers_index_on_commitment =\n active_stakers_index ctxt rollup stakers_on_commitment\n in\n if Compare.List_length_with.(active_stakers_index_on_commitment > 0) then\n return (ctxt, [candidate_commitment], [])\n else return (ctxt, [], [candidate_commitment])\n | commitments ->\n List.fold_left_es\n (fun (ctxt, candidate_commitments, dangling_commitments) commitment ->\n let* ctxt, is_candidate =\n is_cementable_candidate_commitment ctxt rollup old_lcc commitment\n in\n if is_candidate then\n return\n (ctxt, commitment :: candidate_commitments, dangling_commitments)\n else\n return\n (ctxt, candidate_commitments, commitment :: dangling_commitments))\n (ctxt, [], [])\n commitments\n\n(** [assert_cement_commitment_met ctxt rollup ~old_lcc new_lcc] asserts that\n the following list of properties are respected:\n\n {ol\n {li The [new_lcc]'s predecessor is the LCC.}\n {li The challenge window period is over.}\n {li [new_lcc] is the only active commitment.}\n }\n*)\nlet assert_cement_commitment_met ctxt rollup ~old_lcc ~new_lcc =\n let open Lwt_result_syntax in\n (* Checks that the commitment's predecessor is the LCC. *)\n let* new_lcc_commitment, ctxt =\n Commitment_storage.get_commitment_unsafe ctxt rollup new_lcc\n in\n let* () =\n fail_unless\n Commitment_hash.(new_lcc_commitment.predecessor = old_lcc)\n Sc_rollup_parent_not_lcc\n in\n (* Checks that the commitment is past the challenge window. *)\n let* ctxt, new_lcc_added =\n Store.Commitment_added.get (ctxt, rollup) new_lcc\n in\n let* () =\n let challenge_windows_in_blocks =\n Constants_storage.sc_rollup_challenge_window_in_blocks ctxt\n in\n let current_level = (Raw_context.current_level ctxt).level in\n let min_level =\n Raw_level_repr.add new_lcc_added challenge_windows_in_blocks\n in\n fail_when\n Raw_level_repr.(current_level < min_level)\n (Sc_rollup_commitment_too_recent {current_level; min_level})\n in\n (* Checks that the commitment is the only active commitment. *)\n let* ctxt, candidate_commitments, dangling_commitments =\n cementable_candidate_commitments_of_inbox_level\n ctxt\n rollup\n ~old_lcc\n ~new_lcc\n new_lcc_commitment.inbox_level\n in\n match candidate_commitments with\n (* A commitment can be cemented if there is only one valid\n commitment, and it matches the commitment provided. The\n commitment provided is then not strictly required. *)\n | [candidate_commitment] ->\n if Commitment_hash.equal candidate_commitment new_lcc then\n return (ctxt, new_lcc_commitment, dangling_commitments)\n else\n tzfail\n (Sc_rollup_invalid_commitment_to_cement\n {\n valid_candidate = candidate_commitment;\n invalid_candidate = new_lcc;\n })\n | _ -> tzfail Sc_rollup_disputed\n\nlet deallocate_inbox_level ctxt rollup inbox_level new_lcc_hash\n dangling_commitments =\n let open Lwt_result_syntax in\n let* ctxt, _size_diff =\n Commitments_per_inbox_level.remove ctxt rollup inbox_level\n in\n let* ctxt =\n List.fold_left_es\n (fun ctxt commitment -> deallocate_commitment ctxt rollup commitment)\n ctxt\n dangling_commitments\n in\n let* ctxt =\n List.fold_left_es\n (fun ctxt commitment ->\n let* ctxt, _freed_size =\n Commitment_stakers.remove ctxt rollup commitment\n in\n return ctxt)\n ctxt\n (new_lcc_hash :: dangling_commitments)\n in\n let* ctxt = deallocate_commitment_metadata ctxt rollup new_lcc_hash in\n let* ctxt, _size_freed =\n Store.Commitment_first_publication_level.remove_existing\n (ctxt, rollup)\n inbox_level\n in\n return ctxt\n\nlet update_saved_cemented_commitments ctxt rollup old_lcc =\n let open Lwt_result_syntax in\n let* too_old_cemented_commitment_hash_opt, ctxt =\n find_commitment_to_deallocate ctxt rollup old_lcc\n in\n match too_old_cemented_commitment_hash_opt with\n | None -> return ctxt\n | Some too_old_cemented_commitment_hash ->\n if Commitment_hash.(equal too_old_cemented_commitment_hash zero) then\n return ctxt\n else\n deallocate_commitment_contents\n ctxt\n rollup\n too_old_cemented_commitment_hash\n\nlet cement_commitment ctxt rollup new_lcc =\n let open Lwt_result_syntax in\n let* old_lcc, ctxt =\n Commitment_storage.last_cemented_commitment ctxt rollup\n in\n (* Assert conditions to cement are met. *)\n let* ctxt, new_lcc_commitment, dangling_commitments =\n assert_cement_commitment_met ctxt rollup ~old_lcc ~new_lcc\n in\n (* Update the LCC. *)\n let* ctxt, _size_diff =\n Store.Last_cemented_commitment.update ctxt rollup new_lcc\n in\n (* Clean the storage. *)\n let* ctxt =\n deallocate_inbox_level\n ctxt\n rollup\n new_lcc_commitment.inbox_level\n new_lcc\n dangling_commitments\n in\n (* Update the saved cemented commitments. *)\n let* ctxt = update_saved_cemented_commitments ctxt rollup old_lcc in\n return (ctxt, new_lcc_commitment)\n\nlet remove_staker ctxt rollup staker =\n let open Lwt_result_syntax in\n let staker_contract, stake = get_contract_and_stake ctxt staker in\n let bond_id = Bond_id_repr.Sc_rollup_bond_id rollup in\n let* ctxt, balance_updates =\n Token.transfer\n ctxt\n (`Frozen_bonds (staker_contract, bond_id))\n `Sc_rollup_refutation_punishments\n stake\n in\n let* ctxt = Sc_rollup_staker_index_storage.remove_staker ctxt rollup staker in\n return (ctxt, balance_updates)\n\nlet commitments_of_inbox_level = Commitments_per_inbox_level.get\n\nlet stakers_of_commitment = Commitment_stakers.get\n\nmodule Internal_for_tests = struct\n let deposit_stake = deposit_stake\n\n let refine_stake ctxt rollup staker commitment =\n let open Lwt_result_syntax in\n let* lcc, lcc_inbox_level, _ctxt =\n Commitment_storage.last_cemented_commitment_hash_with_level ctxt rollup\n in\n let* _ctxt, staker_index =\n Sc_rollup_staker_index_storage.get_staker_index_unsafe ctxt rollup staker\n in\n let* commitment_hash, publication_level, ctxt, size_diff =\n refine_stake ctxt rollup commitment ~staker_index ~lcc ~lcc_inbox_level\n in\n assert (Compare.Int.(size_diff < max_commitment_storage_size_in_bytes)) ;\n return (commitment_hash, publication_level, ctxt)\n\n let max_commitment_storage_size_in_bytes =\n max_commitment_storage_size_in_bytes\nend\n" ;
} ;
{ name = "Sc_rollup_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 TriliTech <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** [originate context ~kind ~parameters_ty ~genesis_commitment] produces an\n address [a] for a smart contract rollup using the origination nonce found in\n [context]. This function also initializes the storage with a new\n entry indexed by [a] to remember the [kind] of the rollup at\n address [a].\n\n Also returns the number of allocated bytes. *)\nval originate :\n Raw_context.t ->\n kind:Sc_rollups.Kind.t ->\n parameters_ty:Script_repr.lazy_expr ->\n genesis_commitment:Sc_rollup_commitment_repr.t ->\n (Sc_rollup_repr.Address.t\n * Z.t\n * Sc_rollup_commitment_repr.Hash.t\n * Raw_context.t)\n tzresult\n Lwt.t\n\n(** [kind context address] returns the kind of the given rollup [address] iff\n [address] is an existing rollup. Fails with an [Sc_rollup_does_not_exist]\n error in case the rollup does not exist. *)\nval kind :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n (Raw_context.t * Sc_rollups.Kind.t) tzresult Lwt.t\n\nval list_unaccounted : Raw_context.t -> Sc_rollup_repr.t list tzresult Lwt.t\n\n(** [genesis_info ctxt sc_rollup] returns the level at which a [sc_rollup] was\n originated, and its genesis commitment hash. *)\nval genesis_info :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n (Raw_context.t * Sc_rollup_commitment_repr.genesis_info) tzresult Lwt.t\n\n(** [get_metadata ctxt rollup] retrieves the origination level of the [rollup]\n using {!Sc_rollup_commitment_repr.genesis_info} and creates a\n {!Sc_rollup_metadata_repr.t}.\n Fails with [Sc_rollup_does_not_exist {rollup}] if the genesis info is\n missing. *)\nval get_metadata :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n (Raw_context.t * Sc_rollup_metadata_repr.t) tzresult Lwt.t\n\n(** [parameters_type ctxt rollup] returns the registered type of a rollup.\n Returns [None] in case there is no registered type for the rollup. *)\nval parameters_type :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n (Script_repr.lazy_expr option * Raw_context.t) tzresult Lwt.t\n\n(** [must_exist ctxt rollup] checks whether the given [rollup] exists\n in [ctxt]. If [rollup] exists, a new context is returned with gas\n consumed for the lookup cost. If it does not exist, an error is\n returned. *)\nval must_exist :\n Raw_context.t -> Sc_rollup_repr.t -> Raw_context.t tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 TriliTech <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Sc_rollup_errors\nmodule Store = Storage.Sc_rollup\nmodule Commitment = Sc_rollup_commitment_repr\nmodule Commitment_hash = Commitment.Hash\n\n(** [address_from_nonce ctxt nonce] produces an address completely determined by\n an operation hash and an origination counter, and accounts for gas spent. *)\nlet address_from_nonce ctxt nonce =\n let open Result_syntax in\n let* ctxt =\n Raw_context.consume_gas ctxt Sc_rollup_costs.Constants.cost_serialize_nonce\n in\n match Data_encoding.Binary.to_bytes_opt Origination_nonce.encoding nonce with\n | None -> error Sc_rollup_address_generation\n | Some nonce_bytes ->\n let bytes_len = Bytes.length nonce_bytes in\n let+ ctxt =\n Raw_context.consume_gas\n ctxt\n (Sc_rollup_costs.cost_hash_bytes ~bytes_len)\n in\n (ctxt, Sc_rollup_repr.Address.hash_bytes [nonce_bytes])\n\nlet originate ctxt ~kind ~parameters_ty ~genesis_commitment =\n let open Lwt_result_syntax in\n let*? ctxt, genesis_commitment_hash =\n Sc_rollup_commitment_storage.hash ctxt genesis_commitment\n in\n let*? ctxt, nonce = Raw_context.increment_origination_nonce ctxt in\n let*? ctxt, address = address_from_nonce ctxt nonce in\n let* ctxt, pvm_kind_size, _kind_existed =\n Store.PVM_kind.add ctxt address kind\n in\n let origination_level = (Raw_context.current_level ctxt).level in\n let* ctxt, genesis_info_size, _info_existed =\n Store.Genesis_info.add\n ctxt\n address\n {commitment_hash = genesis_commitment_hash; level = origination_level}\n in\n let* ctxt, param_ty_size_diff, _added =\n Store.Parameters_type.add ctxt address parameters_ty\n in\n let* ctxt = Sc_rollup_staker_index_storage.init ctxt address in\n let* ctxt, lcc_size_diff =\n Store.Last_cemented_commitment.init ctxt address genesis_commitment_hash\n in\n let* ctxt, commitment_size_diff, _was_bound =\n Store.Commitments.add\n (ctxt, address)\n genesis_commitment_hash\n genesis_commitment\n in\n (* Those stores [Store.Commitment_added] and [Store.Commitment_stake_count]\n are going to be used to look this bootstrap commitment.\n This commitment is added here so the\n [sc_rollup_state_storage.deallocate] function does not have to handle a\n edge case.\n *)\n let* ctxt, commitment_added_size_diff, _commitment_existed =\n Store.Commitment_added.add\n (ctxt, address)\n genesis_commitment_hash\n origination_level\n in\n (* Those stores [Store.Commitment_first_publication_level] and\n [Store.Commitment_count_per_inbox_level] are populated with dummy values,\n in order the [sc_rollup_state_storage.deallocate_commitment_metadata]\n function does not have to handle an edge case of genesis commitment hash.\n *)\n let* ctxt, commitment_first_publication_level_diff, _existed =\n Store.Commitment_first_publication_level.add\n (ctxt, address)\n origination_level\n origination_level\n in\n let* ctxt, commitments_per_inbox_level_diff =\n Store.Commitments_per_inbox_level.init\n (ctxt, address)\n origination_level\n [genesis_commitment_hash]\n in\n let addresses_size = 2 * Sc_rollup_repr.Address.size in\n let stored_kind_size = 2 (* because tag_size of kind encoding is 16bits. *) in\n let origination_size = Constants_storage.sc_rollup_origination_size ctxt in\n let size =\n Z.of_int\n (origination_size + stored_kind_size + addresses_size + lcc_size_diff\n + commitment_size_diff + commitment_added_size_diff\n + commitment_first_publication_level_diff + param_ty_size_diff\n + pvm_kind_size + genesis_info_size + commitments_per_inbox_level_diff)\n in\n return (address, size, genesis_commitment_hash, ctxt)\n\nlet kind ctxt address =\n let open Lwt_result_syntax in\n let* ctxt, kind_opt = Store.PVM_kind.find ctxt address in\n match kind_opt with\n | Some k -> return (ctxt, k)\n | None -> tzfail (Sc_rollup_errors.Sc_rollup_does_not_exist address)\n\nlet list_unaccounted ctxt =\n let open Lwt_syntax in\n let+ res = Store.PVM_kind.keys_unaccounted ctxt in\n Result.return res\n\nlet genesis_info ctxt rollup =\n let open Lwt_result_syntax in\n let* ctxt, genesis_info = Store.Genesis_info.find ctxt rollup in\n match genesis_info with\n | None -> tzfail (Sc_rollup_does_not_exist rollup)\n | Some genesis_info -> return (ctxt, genesis_info)\n\nlet get_metadata ctxt rollup =\n let open Lwt_result_syntax in\n let* ctxt, genesis_info = genesis_info ctxt rollup in\n let metadata : Sc_rollup_metadata_repr.t =\n {address = rollup; origination_level = genesis_info.level}\n in\n return (ctxt, metadata)\n\nlet parameters_type ctxt rollup =\n let open Lwt_result_syntax in\n let+ ctxt, res = Store.Parameters_type.find ctxt rollup in\n (res, ctxt)\n\nlet must_exist ctxt rollup =\n let open Lwt_result_syntax in\n let+ ctxt, _info = genesis_info ctxt rollup in\n ctxt\n" ;
} ;
{ name = "Dal_slot_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Storage management of slots for the data-availability layer.\n\n {1 Overview}\n\n This module is an interface for the slot storage for the layer 1.\n\n Depending on the current level of the context and the [lag] (a\n constant given by the context), the status of the slot may differ:\n\n - For every level in the interval [current_level; current_level +\n lag -1] the slot is [Pending]. This means a slot header was\n proposed but was not declared available yet.\n\n - For every level above [current_level + lag], the slot may be\n [confirmed]. For any slot confirmed by the protocol (i.e. indices\n returned by [finalize_pending_slots]), subscribers of the DAL\n should take into account the corresponding slots.\n\n - For every level below [current_level - lag], there should not be\n any slot in the storage. *)\n\n(** [find_slot_headers ctxt level] returns [Some slot_headers] where [slot_headers]\n are pending slots at level [level]. [None] is returned if no\n [slot_header] was registered at this level. The function fails if\n the reading into the context fails. *)\nval find_slot_headers :\n Raw_context.t ->\n Raw_level_repr.t ->\n Dal_slot_repr.Header.t list option tzresult Lwt.t\n\n(** [finalize_current_slot_headers ctxt] finalizes the current slot\n headers posted on this block and marks them as pending into the\n context. *)\nval finalize_current_slot_headers : Raw_context.t -> Raw_context.t Lwt.t\n\n(** [finalize_pending_slot_headers ctxt] finalizes pending slot\n headers which are old enough (i.e. registered at level\n [current_level - lag]). All slots marked as available are\n returned. All the pending slots at [current_level - lag] level are\n removed from the context. *)\nval finalize_pending_slot_headers :\n Raw_context.t -> (Raw_context.t * Dal_attestation_repr.t) tzresult Lwt.t\n\n(** [get_slot_headers_history ctxt] returns the current value of slots_history stored\n in [ctxt], or Slots_history.genesis if no value is stored yet. *)\nval get_slot_headers_history :\n Raw_context.t -> Dal_slot_repr.History.t tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nlet find_slot_headers ctxt level = Storage.Dal.Slot.Headers.find ctxt level\n\nlet finalize_current_slot_headers ctxt =\n let current_level = Raw_context.current_level ctxt in\n let slot_headers = Raw_context.Dal.candidates ctxt in\n match slot_headers with\n | [] -> Lwt.return ctxt\n | _ :: _ -> Storage.Dal.Slot.Headers.add ctxt current_level.level slot_headers\n\nlet compute_available_slot_headers ctxt seen_slot_headers =\n let open Dal_slot_repr in\n let fold_available_slots (rev_slot_headers, available_slot_headers) slot =\n if Raw_context.Dal.is_slot_index_available ctxt slot.Header.id.index then\n ( slot :: rev_slot_headers,\n Dal_attestation_repr.commit available_slot_headers slot.Header.id.index\n )\n else (rev_slot_headers, available_slot_headers)\n in\n List.fold_left\n fold_available_slots\n ([], Dal_attestation_repr.empty)\n seen_slot_headers\n\nlet get_slot_headers_history ctxt =\n Storage.Dal.Slot.History.find ctxt >|=? function\n | None -> Dal_slot_repr.History.genesis\n | Some slots_history -> slots_history\n\nlet update_skip_list ctxt ~confirmed_slot_headers =\n get_slot_headers_history ctxt >>=? fun slots_history ->\n Lwt.return\n @@ Dal_slot_repr.History.add_confirmed_slot_headers_no_cache\n slots_history\n confirmed_slot_headers\n >>=? fun slots_history ->\n Storage.Dal.Slot.History.add ctxt slots_history >|= ok\n\nlet finalize_pending_slot_headers ctxt =\n let {Level_repr.level = raw_level; _} = Raw_context.current_level ctxt in\n let Constants_parametric_repr.{dal; _} = Raw_context.constants ctxt in\n match Raw_level_repr.(sub raw_level dal.attestation_lag) with\n | None -> return (ctxt, Dal_attestation_repr.empty)\n | Some level_attested -> (\n Storage.Dal.Slot.Headers.find ctxt level_attested >>=? function\n | None -> return (ctxt, Dal_attestation_repr.empty)\n | Some seen_slots ->\n let rev_confirmed_slot_headers, available_slot_headers =\n compute_available_slot_headers ctxt seen_slots\n in\n let confirmed_slot_headers = List.rev rev_confirmed_slot_headers in\n update_skip_list ctxt ~confirmed_slot_headers >>=? fun ctxt ->\n Storage.Dal.Slot.Headers.remove ctxt level_attested >>= fun ctxt ->\n return (ctxt, available_slot_headers))\n" ;
} ;
{ name = "Sc_rollup_refutation_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 TriliTech <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule Commitment_hash = Sc_rollup_commitment_repr.Hash\n\ntype point = {\n commitment : Sc_rollup_commitment_repr.t;\n hash : Commitment_hash.t;\n}\n\ntype conflict_point = point * point\n\n(** [get_ongoing_games_for_staker ctxt rollup staker] returns [games],\n the list of refutation games currently played by [staker] in the\n [rollup]. *)\nval get_ongoing_games_for_staker :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Sc_rollup_repr.Staker.t ->\n ((Sc_rollup_game_repr.t * Sc_rollup_game_repr.Index.t) list * Raw_context.t)\n tzresult\n Lwt.t\n\n(** A conflict between a staker and an [other] staker. The conflict is\n about the commitment that follows the [parent_commitment]:\n [their_commitment] and [our_commitment] are distinct, hence in\n conflict. *)\ntype conflict = {\n other : Sc_rollup_repr.Staker.t;\n their_commitment : Sc_rollup_commitment_repr.t;\n our_commitment : Sc_rollup_commitment_repr.t;\n parent_commitment : Sc_rollup_commitment_repr.Hash.t;\n}\n\nval conflict_encoding : conflict Data_encoding.t\n\n(** [conflicting_stakers_uncarbonated rollup staker] returns the list\n of conflicts with [staker] in [rollup].\n\n Notice that this operation can be expensive as it is proportional\n to the number of stakers multiplied by the number of commitments in\n the staked branches. Fortunately, this operation is only useful as\n an RPC for the rollup node to look for a new conflict to solve. *)\nval conflicting_stakers_uncarbonated :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Sc_rollup_repr.Staker.t ->\n conflict list tzresult Lwt.t\n\n(** [start_game ctxt rollup ~player:(player, player_commitment_hash)\n ~opponent:(opponent, opponent_commitment_hash)] initiates a refutation game\n between [player] and [opponent] in the given [rollup] as they are in\n conflict with [commitment] and [opponent_commitment]. Where [commitment] is\n the commitment in the storage with hash [player_commitment_hash]\n (resp. [opponent_commitment] with [opponent_commitment_hash]). *)\nval start_game :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n player:Signature.public_key_hash * Sc_rollup_commitment_repr.Hash.t ->\n opponent:Signature.public_key_hash * Sc_rollup_commitment_repr.Hash.t ->\n Raw_context.t tzresult Lwt.t\n\n(** [game_move ctxt rollup player opponent refutation]\n handles the storage-side logic for when one of the players makes a\n move in the game. It checks the game already exists. Then it checks\n that [player] is the player whose turn it is; if so, it applies\n [refutation] using the [play] function.\n\n If the result is a new game, this is stored and the timeout is updated.\n\n May fail with:\n {ul\n {li [Sc_rollup_does_not_exist] if [rollup] does not exist}\n {li [Sc_rollup_no_game] if [is_opening_move] is [false] but the\n game does not exist}\n {li [Sc_rollup_game_already_started] if [is_opening_move] is [true]\n but the game already exists}\n {li [Sc_rollup_no_conflict] if [player] is staked on an ancestor of\n the commitment staked on by [opponent], or vice versa}\n {li [Sc_rollup_not_staked] if one of the [player] or [opponent] is\n not actually staked}\n {li [Sc_rollup_staker_in_game] if one of the [player] or [opponent]\n is already playing a game}\n {li [Sc_rollup_wrong_turn] if a player is trying to move out of\n turn}\n }\n\n The [is_opening_move] argument is included here to make sure that an\n operation intended to start a refutation game is never mistaken for\n an operation to play the second move of the game---this may\n otherwise happen due to non-deterministic ordering of L1 operations.\n With the [is_opening_move] parameter, the worst case is that the\n operation simply fails. Without it, the operation would be mistaken\n for an invalid move in the game and the staker would lose their\n stake! *)\nval game_move :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n player:Sc_rollup_repr.Staker.t ->\n opponent:Sc_rollup_repr.Staker.t ->\n step:Sc_rollup_game_repr.step ->\n choice:Sc_rollup_tick_repr.t ->\n (Sc_rollup_game_repr.game_result option * Raw_context.t) tzresult Lwt.t\n\n(** [timeout ctxt rollup stakers] checks that the timeout has\n elapsed and if this function returns a game result that punishes whichever\n of [stakers] is supposed to have played a move.\n\n The timeout period is defined a protocol constant, see\n {!Constants_storage.sc_rollup_timeout_period_in_blocks}.\n\n May fail with:\n {ul\n {li [Sc_rollup_no_game] if the game does not in fact exist}\n {li [Sc_rollup_timeout_level_not_reached] if the player still has\n time in which to play}\n }\n\n Note: this function takes the two stakers as a pair rather than\n separate arguments. This reflects the fact that for this function\n the two players are symmetric. This function will normalize the\n order of the players if necessary to get a valid game index, so the\n argument [stakers] doesn't have to be in normal form. *)\nval timeout :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Sc_rollup_game_repr.Index.t ->\n (Sc_rollup_game_repr.game_result * Raw_context.t) tzresult Lwt.t\n\n(** [get_timeout ctxt rollup stakers] returns the current timeout values of both\n players. *)\nval get_timeout :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Sc_rollup_game_repr.Index.t ->\n (Sc_rollup_game_repr.timeout * Raw_context.t) tzresult Lwt.t\n\n(** [apply_game_result ctxt rollup game_result] takes a [game_result] produced\n by [timeout] or [game_move] and performs the necessary end-of-game\n cleanup: remove the game itself from the store and punish the losing\n player by removing their stake. In the case where the game ended in\n a draw, both players are slashed.\n\n This is mostly just calling [remove_staker], so it can fail with the\n same errors as that. However, if it is called on an [game_result]\n generated by [game_move] or [timeout] it should not fail.\n\n Note: this function takes the two stakers as a pair rather than\n separate arguments. This reflects the fact that for this function\n the two players are symmetric. This function will normalize the\n order of the players if necessary to get a valid game index, so the\n argument [stakers] doesn't have to be in normal form. *)\nval apply_game_result :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Sc_rollup_game_repr.Index.t ->\n Sc_rollup_game_repr.game_result ->\n (Sc_rollup_game_repr.status * Raw_context.t * Receipt_repr.balance_updates)\n tzresult\n Lwt.t\n\n(**/**)\n\nmodule Internal_for_tests : sig\n (** [get_conflict_point context rollup staker1 staker2] returns the\n first point of disagreement between the [staker1] and the\n [staker2]\n The returned commitments are distinct, and have the same [parent]\n commitment; hence the same inbox level.\n\n May fail with:\n {ul\n {li [Sc_rollup_does_not_exist] if [rollup] does not exist}\n {li [Sc_rollup_no_conflict] if [staker1] is staked on an ancestor of the\n commitment staked on by [staker2], or vice versa}\n {li [Sc_rollup_not_staked] if one of the stakers is not staked}\n } *)\n val get_conflict_point :\n Raw_context.t ->\n Sc_rollup_repr.t ->\n Sc_rollup_repr.Staker.t ->\n Sc_rollup_repr.Staker.t ->\n (conflict_point * Raw_context.t) tzresult Lwt.t\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 TriliTech <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Sc_rollup_errors\nmodule Store = Storage.Sc_rollup\nmodule Commitment = Sc_rollup_commitment_repr\nmodule Commitment_storage = Sc_rollup_commitment_storage\nmodule Commitment_hash = Commitment.Hash\nmodule Stake_storage = Sc_rollup_stake_storage\n\ntype point = {\n commitment : Sc_rollup_commitment_repr.t;\n hash : Commitment_hash.t;\n}\n\ntype conflict_point = point * point\n\n(** [initial_timeout ctxt] set the initial timeout of players. The initial\n timeout of each player is equal to [sc_rollup_timeout_period_in_blocks]. *)\nlet initial_timeout ctxt =\n let last_turn_level = (Raw_context.current_level ctxt).level in\n let timeout_period_in_blocks =\n Constants_storage.sc_rollup_timeout_period_in_blocks ctxt\n in\n Sc_rollup_game_repr.\n {\n alice = timeout_period_in_blocks;\n bob = timeout_period_in_blocks;\n last_turn_level;\n }\n\n(** [update_timeout ctxt rollup game idx] update the timeout left for the\n current player [game.turn]. Her new timeout is equal to [nb_of_block_left -\n (current_level - last_turn_level)] where [nb_of_block_left] is her current\n timeout. *)\nlet update_timeout ctxt rollup (game : Sc_rollup_game_repr.t) idx =\n let open Lwt_result_syntax in\n let* ctxt, timeout = Store.Game_timeout.get (ctxt, rollup) idx in\n let current_level = (Raw_context.current_level ctxt).level in\n let sub_block_left nb_of_block_left =\n nb_of_block_left\n - Int32.to_int (Raw_level_repr.diff current_level timeout.last_turn_level)\n in\n let new_timeout =\n match game.turn with\n | Alice ->\n let nb_of_block_left = sub_block_left timeout.alice in\n {timeout with last_turn_level = current_level; alice = nb_of_block_left}\n | Bob ->\n let nb_of_block_left = sub_block_left timeout.bob in\n {timeout with last_turn_level = current_level; bob = nb_of_block_left}\n in\n let* ctxt, _ = Store.Game_timeout.update (ctxt, rollup) idx new_timeout in\n return ctxt\n\nlet get_ongoing_games_for_staker ctxt rollup staker =\n let open Lwt_result_syntax in\n let* ctxt, entries = Store.Game.list_key_values ((ctxt, rollup), staker) in\n let* ctxt, games =\n List.fold_left_es\n (fun (ctxt, games) (opponent, game_index) ->\n let* ctxt, answer = Store.Game_info.find (ctxt, rollup) game_index in\n match answer with\n | None ->\n (* A hash in [Store.Game] is always present in [Store.Game_info]. *)\n assert false\n | Some game ->\n let games =\n (game, Sc_rollup_game_repr.Index.make staker opponent) :: games\n in\n return (ctxt, games))\n (ctxt, [])\n entries\n in\n return (games, ctxt)\n\n(** [commitments_are_conflicting ctxt rollup hash1_opt hash2_opt]\n returns a conflict description iff [hash1_opt] and [hash2_opt] are\n two different commitments with the same predecessor. *)\nlet commitments_are_conflicting ctxt rollup hash1_opt hash2_opt =\n let open Lwt_result_syntax in\n match (hash1_opt, hash2_opt) with\n | Some hash1, Some hash2 when Commitment_hash.(hash1 <> hash2) ->\n let* commitment1, ctxt =\n Commitment_storage.get_commitment_unsafe ctxt rollup hash1\n in\n let* commitment2, ctxt =\n Commitment_storage.get_commitment_unsafe ctxt rollup hash2\n in\n if Commitment_hash.(commitment1.predecessor = commitment2.predecessor)\n then\n let conflict_point =\n ( {hash = hash1; commitment = commitment1},\n {hash = hash2; commitment = commitment2} )\n in\n return (ctxt, Some conflict_point)\n else return (ctxt, None)\n | _ -> return (ctxt, None)\n\n(** [look_for_conflict ctxt rollup staker1_index staker2_index from_level\n upto_level delta] looks for the first conflict of [staker1_index]\n and [staker2_index].\n\n It starts at [from_level] which the last cemented inbox level on the\n [rollup], and climbs the staking's storage through a recursive\n function.\n\n Two important notes:\n {ol\n {li The code can do at most (max_lookahead / commitment_period) recursive\n calls, which can be a lot;}\n {li Therefore, this code must be called only via a RPC, used by the\n rollup-node. The {!check_conflict_point} used by the protocol is\n on the other hand, very cheap.}\n }\n\n FIXME: https://gitlab.com/tezos/tezos/-/issues/4477\n As it should be used only via an RPC (and by the rollup-node), we should\n move this function (and other related functions) outside the protocol.\n*)\nlet look_for_conflict ctxt rollup staker1_index staker2_index from_level\n upto_level delta =\n let open Lwt_result_syntax in\n let rec go ctxt from_level =\n if Raw_level_repr.(from_level >= upto_level) then\n tzfail Sc_rollup_no_conflict\n else\n let* ctxt, commitments =\n Sc_rollup_stake_storage.commitments_of_inbox_level\n ctxt\n rollup\n from_level\n in\n let* ctxt, hash1_opt =\n Sc_rollup_stake_storage.find_commitment_of_staker_in_commitments\n ctxt\n rollup\n staker1_index\n commitments\n in\n let* ctxt, hash2_opt =\n Sc_rollup_stake_storage.find_commitment_of_staker_in_commitments\n ctxt\n rollup\n staker2_index\n commitments\n in\n let* ctxt, conflict_point_opt =\n commitments_are_conflicting ctxt rollup hash1_opt hash2_opt\n in\n match conflict_point_opt with\n | Some conflict_point -> return (conflict_point, ctxt)\n | None ->\n let from_level = Raw_level_repr.add from_level delta in\n go ctxt from_level\n in\n go ctxt from_level\n\n(** [get_conflict_point ctxt rollup staker1 staker2] starts from the\n LCC's successor and look for the first conflict between [staker1] and\n [staker2], if any. *)\nlet get_conflict_point ctxt rollup staker1 staker2 =\n let open Lwt_result_syntax in\n let* ctxt, staker1_index =\n Sc_rollup_staker_index_storage.get_staker_index_unsafe ctxt rollup staker1\n in\n let* ctxt, staker2_index =\n Sc_rollup_staker_index_storage.get_staker_index_unsafe ctxt rollup staker2\n in\n let* _lcc, lcc_inbox_level, ctxt =\n Commitment_storage.last_cemented_commitment_hash_with_level ctxt rollup\n in\n let current_level = (Raw_context.current_level ctxt).level in\n let commitment_period =\n Constants_storage.sc_rollup_commitment_period_in_blocks ctxt\n in\n look_for_conflict\n ctxt\n rollup\n staker1_index\n staker2_index\n (Raw_level_repr.add lcc_inbox_level commitment_period)\n current_level\n commitment_period\n\nlet get_game ctxt rollup stakers =\n let open Lwt_result_syntax in\n let open Sc_rollup_game_repr.Index in\n let* ctxt, game_index =\n Store.Game.find ((ctxt, rollup), stakers.alice) stakers.bob\n in\n match game_index with\n | None -> tzfail Sc_rollup_no_game\n | Some game_hash -> (\n let* ctxt, game = Store.Game_info.find (ctxt, rollup) game_hash in\n match game with\n | Some game -> return (game, ctxt)\n | None -> tzfail Sc_rollup_no_game)\n\nlet create_game ctxt rollup stakers game =\n let open Lwt_result_syntax in\n let open Sc_rollup_game_repr.Index in\n let* ctxt, _ = Store.Game_info.init (ctxt, rollup) stakers game in\n let* ctxt, _ =\n Store.Game.init ((ctxt, rollup), stakers.alice) stakers.bob stakers\n in\n let* ctxt, _ =\n Store.Game.init ((ctxt, rollup), stakers.bob) stakers.alice stakers\n in\n return ctxt\n\nlet update_game ctxt rollup stakers new_game =\n let open Lwt_result_syntax in\n let* ctxt, _storage_diff =\n Store.Game_info.update (ctxt, rollup) stakers new_game\n in\n return ctxt\n\nlet remove_game ctxt rollup stakers =\n let open Lwt_result_syntax in\n let open Sc_rollup_game_repr.Index in\n let* ctxt, _storage_diff, _was_here =\n Store.Game.remove ((ctxt, rollup), stakers.alice) stakers.bob\n in\n let* ctxt, _storage_diff, _was_here =\n Store.Game.remove ((ctxt, rollup), stakers.bob) stakers.alice\n in\n let* ctxt, _storage_diff, _was_here =\n Store.Game_info.remove (ctxt, rollup) stakers\n in\n return ctxt\n\n(** [check_conflict_point ctxt rollup ~refuter ~refuter_commitment_hash\n ~defender ~defender_commitment_hash] checks that the refuter is staked on\n [commitment] with hash [refuter_commitment_hash], res. for [defender] and\n [defender_commitment] with hash [defender_commitment_hash]. Fails with\n {!Sc_rollup_errors.Sc_rollup_wrong_staker_for_conflict_commitment}.\n\n It also verifies that both are pointing to the same predecessor and thus are\n in conflict, fails with\n {!Sc_rollup_errors.Sc_rollup_not_first_conflict_between_stakers} otherwise.\n*)\nlet check_conflict_point ctxt rollup ~refuter ~refuter_commitment_hash ~defender\n ~defender_commitment_hash =\n let open Lwt_result_syntax in\n let fail_unless_staker_is_staked_on_commitment ctxt staker commitment_hash =\n let* ctxt, is_staked =\n Sc_rollup_stake_storage.is_staked_on ctxt rollup staker commitment_hash\n in\n let* () =\n fail_unless\n is_staked\n (Sc_rollup_wrong_staker_for_conflict_commitment (staker, commitment_hash))\n in\n return ctxt\n in\n let* ctxt =\n fail_unless_staker_is_staked_on_commitment\n ctxt\n refuter\n refuter_commitment_hash\n in\n let* ctxt =\n fail_unless_staker_is_staked_on_commitment\n ctxt\n defender\n defender_commitment_hash\n in\n let* refuter_commitment, ctxt =\n Commitment_storage.get_commitment_unsafe ctxt rollup refuter_commitment_hash\n in\n let* defender_commitment, ctxt =\n Commitment_storage.get_commitment_unsafe\n ctxt\n rollup\n defender_commitment_hash\n in\n let* () =\n fail_unless\n Commitment_hash.(refuter_commitment_hash <> defender_commitment_hash)\n Sc_rollup_errors.Sc_rollup_no_conflict\n in\n let* () =\n fail_unless\n Commitment_hash.(\n refuter_commitment.predecessor = defender_commitment.predecessor)\n (Sc_rollup_errors.Sc_rollup_not_valid_commitments_conflict\n (refuter_commitment_hash, refuter, defender_commitment_hash, defender))\n in\n return (defender_commitment, ctxt)\n\nlet check_staker_availability ctxt rollup staker =\n let open Lwt_result_syntax in\n let* ctxt, is_staker =\n Sc_rollup_staker_index_storage.is_staker ctxt rollup staker\n in\n let* () = fail_unless is_staker Sc_rollup_not_staked in\n let* ctxt, entries = Store.Game.list_key_values ((ctxt, rollup), staker) in\n let* () =\n fail_when\n Compare.List_length_with.(\n entries >= Constants_storage.sc_rollup_max_number_of_parallel_games ctxt)\n (Sc_rollup_max_number_of_parallel_games_reached staker)\n in\n return ctxt\n\n(** [start_game ctxt rollup ~player:(player, player_commitment_hash)\n ~opponent:(opponent, opponent_commitment_hash)] initialises the game or if\n it already exists fails with [Sc_rollup_game_already_started].\n\n The game is created with [player] as the first player to\n move. The initial state of the game will be obtained from the\n commitment pair belonging to [opponent] at the conflict point. See\n [Sc_rollup_game_repr.initial] for documentation on how a pair of\n commitments is turned into an initial game state.\n\n This also deals with the other bits of data in the storage around\n the game. Notice that a staker can participate in multiple games in\n parallel. However, there is at most one game between two given stakers\n since a staker can publish at most one commitment per inbox level.\n\n It also initialises the timeout level to the current level plus\n [timeout_period_in_blocks] to mark the block level at which it becomes\n possible for anyone to end the game by timeout.\n\n May fail with:\n\n {ul\n {li [Sc_rollup_does_not_exist] if [rollup] does not exist}\n {li [Sc_rollup_no_conflict] if [player] is staked on an\n ancestor of the commitment staked on by [opponent], or vice versa}\n {li [Sc_rollup_not_staked] if one of the [player] or [opponent] is\n not actually staked}\n {li [Sc_rollup_staker_in_game] if one of the [player] or [opponent]\n is already playing a game}\n {li [Sc_rollup_not_first_conflict_between_stakers] if the provided\n commitments are not the first commitments in conflict between\n [player] and [opponent].}\n*)\nlet start_game ctxt rollup ~player:(player, player_commitment_hash)\n ~opponent:(opponent, opponent_commitment_hash) =\n let open Lwt_result_syntax in\n (* When the game is started by a given [player], this player is\n called the [refuter] and its opponent is the [defender]. *)\n let refuter = player\n and refuter_commitment_hash = player_commitment_hash\n and defender = opponent\n and defender_commitment_hash = opponent_commitment_hash in\n let stakers = Sc_rollup_game_repr.Index.make refuter defender in\n let* ctxt, game_exists = Store.Game_info.mem (ctxt, rollup) stakers in\n let* () = fail_when game_exists Sc_rollup_game_already_started in\n let* ctxt = check_staker_availability ctxt rollup stakers.alice in\n let* ctxt = check_staker_availability ctxt rollup stakers.bob in\n let* defender_commitment, ctxt =\n check_conflict_point\n ctxt\n rollup\n ~refuter\n ~defender\n ~refuter_commitment_hash\n ~defender_commitment_hash\n in\n let* parent_commitment, ctxt =\n Commitment_storage.get_commitment_unsafe\n ctxt\n rollup\n defender_commitment.predecessor\n in\n let* inbox, ctxt = Sc_rollup_inbox_storage.get_inbox ctxt in\n let default_number_of_sections =\n Constants_storage.sc_rollup_number_of_sections_in_dissection ctxt\n in\n let* slots_history_snapshot =\n Dal_slot_storage.get_slot_headers_history ctxt\n in\n let current_level = (Raw_context.current_level ctxt).level in\n let game =\n Sc_rollup_game_repr.initial\n ~start_level:current_level\n (Sc_rollup_inbox_repr.take_snapshot inbox)\n slots_history_snapshot\n ~refuter\n ~defender\n ~default_number_of_sections\n ~parent_commitment\n ~defender_commitment\n in\n let* ctxt = create_game ctxt rollup stakers game in\n let* ctxt, _ =\n Store.Game_timeout.init (ctxt, rollup) stakers (initial_timeout ctxt)\n in\n return ctxt\n\nlet check_stakes ctxt rollup (stakers : Sc_rollup_game_repr.Index.t) =\n let open Lwt_result_syntax in\n let open Sc_rollup_game_repr in\n let* ctxt, alice_stake =\n Sc_rollup_staker_index_storage.is_staker ctxt rollup stakers.alice\n in\n let* ctxt, bob_stake =\n Sc_rollup_staker_index_storage.is_staker ctxt rollup stakers.bob\n in\n let game_over loser = Loser {loser; reason = Conflict_resolved} in\n match (alice_stake, bob_stake) with\n | true, true -> return (None, ctxt)\n | false, true -> return (Some (game_over stakers.alice), ctxt)\n | true, false -> return (Some (game_over stakers.bob), ctxt)\n | false, false -> return (Some Draw, ctxt)\n\nlet game_move ctxt rollup ~player ~opponent ~step ~choice =\n let open Lwt_result_syntax in\n let stakers = Sc_rollup_game_repr.Index.make player opponent in\n let* game, ctxt = get_game ctxt rollup stakers in\n let* ctxt, kind = Store.PVM_kind.get ctxt rollup in\n let* () =\n fail_unless\n (Sc_rollup_repr.Staker.equal\n player\n (Sc_rollup_game_repr.Index.staker stakers game.turn))\n Sc_rollup_wrong_turn\n in\n let* ctxt, metadata = Sc_rollup_storage.get_metadata ctxt rollup in\n let dal = (Constants_storage.parametric ctxt).dal in\n let* check_result, ctxt = check_stakes ctxt rollup stakers in\n match check_result with\n | Some game_result -> return (Some game_result, ctxt)\n | None -> (\n let play_cost = Sc_rollup_game_repr.cost_play ~step ~choice in\n let*? ctxt = Raw_context.consume_gas ctxt play_cost in\n let* move_result =\n Sc_rollup_game_repr.play\n kind\n dal.cryptobox_parameters\n ~dal_attestation_lag:dal.attestation_lag\n ~stakers\n metadata\n game\n ~step\n ~choice\n in\n match move_result with\n | Either.Left game_result -> return (Some game_result, ctxt)\n | Either.Right new_game ->\n let* ctxt = update_game ctxt rollup stakers new_game in\n let* ctxt = update_timeout ctxt rollup game stakers in\n return (None, ctxt))\n\nlet get_timeout ctxt rollup stakers =\n let open Lwt_result_syntax in\n let* ctxt, timeout_opt =\n Storage.Sc_rollup.Game_timeout.find (ctxt, rollup) stakers\n in\n match timeout_opt with\n | Some timeout -> return (timeout, ctxt)\n | None -> tzfail Sc_rollup_no_game\n\nlet timeout ctxt rollup stakers =\n let open Lwt_result_syntax in\n let level = (Raw_context.current_level ctxt).level in\n let* game, ctxt = get_game ctxt rollup stakers in\n let* ctxt, timeout = Store.Game_timeout.get (ctxt, rollup) stakers in\n let* () =\n let block_left_before_timeout =\n match game.turn with Alice -> timeout.alice | Bob -> timeout.bob\n in\n let level_of_timeout =\n Raw_level_repr.add timeout.last_turn_level block_left_before_timeout\n in\n fail_unless\n Raw_level_repr.(level > level_of_timeout)\n (let blocks_left = Raw_level_repr.(diff level_of_timeout level) in\n let staker =\n match game.turn with Alice -> stakers.alice | Bob -> stakers.bob\n in\n Sc_rollup_timeout_level_not_reached (blocks_left, staker))\n in\n let game_result =\n match game.game_state with\n | Dissecting _ ->\n (* Timeout during the dissecting results in a loss. *)\n let loser = Sc_rollup_game_repr.Index.staker stakers game.turn in\n Sc_rollup_game_repr.(Loser {loser; reason = Timeout})\n | Final_move {agreed_start_chunk = _; refuted_stop_chunk = _} ->\n (* Timeout-ed because the opponent played an invalid move and\n the current player is not playing. Both are invalid moves. *)\n Sc_rollup_game_repr.Draw\n in\n return (game_result, ctxt)\n\nlet reward ctxt winner =\n let open Lwt_result_syntax in\n let winner_contract = Contract_repr.Implicit winner in\n let stake = Constants_storage.sc_rollup_stake_amount ctxt in\n let*? reward = Tez_repr.(stake /? 2L) in\n Token.transfer\n ctxt\n `Sc_rollup_refutation_rewards\n (`Contract winner_contract)\n reward\n\nlet remove_if_staker_is_still_there ctxt rollup staker =\n let open Lwt_result_syntax in\n let* ctxt, is_staker =\n Sc_rollup_staker_index_storage.is_staker ctxt rollup staker\n in\n if is_staker then Stake_storage.remove_staker ctxt rollup staker\n else return (ctxt, [])\n\nlet apply_game_result ctxt rollup (stakers : Sc_rollup_game_repr.Index.t)\n (game_result : Sc_rollup_game_repr.game_result) =\n let open Lwt_result_syntax in\n let status = Sc_rollup_game_repr.Ended game_result in\n let* ctxt, balances_updates =\n match game_result with\n | Loser {loser; reason = _} ->\n let losing_staker = loser in\n let winning_staker =\n let Sc_rollup_game_repr.Index.{alice; bob} = stakers in\n if Signature.Public_key_hash.(alice = loser) then bob else alice\n in\n let* ctxt = remove_game ctxt rollup stakers in\n let* ctxt, balance_updates_loser =\n remove_if_staker_is_still_there ctxt rollup losing_staker\n in\n let* ctxt, balance_updates_winner =\n (* The winner is rewarded only if he defeated himself the loser.\n Another way to check this is to reward if the game result's reason\n is not a forfeit.\n *)\n match balance_updates_loser with\n | [] -> return (ctxt, [])\n | _ -> reward ctxt winning_staker\n in\n let balances_updates = balance_updates_loser @ balance_updates_winner in\n return (ctxt, balances_updates)\n | Draw ->\n let* ctxt, balances_updates_alice =\n Stake_storage.remove_staker ctxt rollup stakers.alice\n in\n let* ctxt, balances_updates_bob =\n Stake_storage.remove_staker ctxt rollup stakers.bob\n in\n return (ctxt, balances_updates_alice @ balances_updates_bob)\n in\n let* ctxt, _storage_diff, _was_here =\n Store.Game_timeout.remove (ctxt, rollup) stakers\n in\n return (status, ctxt, balances_updates)\n\nmodule Internal_for_tests = struct\n let get_conflict_point = get_conflict_point\nend\n\ntype conflict = {\n other : Sc_rollup_repr.Staker.t;\n their_commitment : Sc_rollup_commitment_repr.t;\n our_commitment : Sc_rollup_commitment_repr.t;\n parent_commitment : Sc_rollup_commitment_repr.Hash.t;\n}\n\nlet conflict_encoding =\n Data_encoding.(\n conv\n (fun {other; their_commitment; our_commitment; parent_commitment} ->\n (other, their_commitment, our_commitment, parent_commitment))\n (fun (other, their_commitment, our_commitment, parent_commitment) ->\n {other; their_commitment; our_commitment; parent_commitment})\n (obj4\n (req \"other\" Sc_rollup_repr.Staker.encoding)\n (req \"their_commitment\" Sc_rollup_commitment_repr.encoding)\n (req \"our_commitment\" Sc_rollup_commitment_repr.encoding)\n (req \"parent_commitment\" Sc_rollup_commitment_repr.Hash.encoding)))\n\nlet conflicting_stakers_uncarbonated ctxt rollup staker =\n let open Lwt_result_syntax in\n let make_conflict ctxt rollup other (our_point, their_point) =\n let our_hash = our_point.hash and their_hash = their_point.hash in\n let get = Sc_rollup_commitment_storage.get_commitment_unsafe ctxt rollup in\n let* our_commitment, _ctxt = get our_hash in\n let* their_commitment, _ctxt = get their_hash in\n let parent_commitment = our_commitment.predecessor in\n return {other; their_commitment; our_commitment; parent_commitment}\n in\n let*! stakers =\n Sc_rollup_stake_storage.stakers_pkhs_uncarbonated ctxt ~rollup\n in\n List.fold_left_es\n (fun conflicts other_staker ->\n let*! res = get_conflict_point ctxt rollup staker other_staker in\n match res with\n | Ok (conflict_point, _) ->\n let* conflict =\n make_conflict ctxt rollup other_staker conflict_point\n in\n return (conflict :: conflicts)\n | Error _ -> return conflicts)\n []\n stakers\n" ;
} ;
{ name = "Zk_rollup_errors" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype error +=\n | Deposit_as_external\n | Invalid_deposit_amount\n | Invalid_deposit_ticket\n | Wrong_deposit_parameters\n | Ticket_payload_size_limit_exceeded of {\n payload_size : Saturation_repr.may_saturate Saturation_repr.t;\n limit : int;\n }\n | Invalid_verification\n | Invalid_circuit\n | Inconsistent_state_update\n | Pending_bound\n\nlet () =\n register_error_kind\n `Temporary\n ~id:\"operation.zk_rollup_deposit_as_external\"\n ~title:\"Zk_rollup: attempted a deposit through an external op\"\n ~description:\"Zk_rollup: attempted a deposit through an external op\"\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"Zk_rollup: attempted a deposit through an external op\")\n Data_encoding.empty\n (function Deposit_as_external -> Some () | _ -> None)\n (fun () -> Deposit_as_external) ;\n register_error_kind\n `Temporary\n ~id:\"operation.zk_rollup_invalid_deposit_amount\"\n ~title:\"Zk_rollup: attempted a deposit with an invalid amount\"\n ~description:\"Zk_rollup: attempted a deposit with an invalid amount\"\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"Zk_rollup: attempted a deposit with an invalid amount\")\n Data_encoding.empty\n (function Invalid_deposit_amount -> Some () | _ -> None)\n (fun () -> Invalid_deposit_amount) ;\n register_error_kind\n `Temporary\n ~id:\"operation.zk_rollup_invalid_deposit_ticket\"\n ~title:\"Zk_rollup: attempted a deposit with an invalid ticket\"\n ~description:\"Zk_rollup: attempted a deposit with an invalid ticket\"\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"Zk_rollup: attempted a deposit with an invalid ticket\")\n Data_encoding.empty\n (function Invalid_deposit_ticket -> Some () | _ -> None)\n (fun () -> Invalid_deposit_ticket) ;\n register_error_kind\n `Permanent\n ~id:\"operation.zk_rollup_wrong_deposit_parameters\"\n ~title:\"Zk_rollup: attempted a deposit with invalid parameters\"\n ~description:\"Zk_rollup: attempted a deposit with invalid parameters\"\n ~pp:(fun ppf () ->\n Format.fprintf\n ppf\n \"Zk_rollup: attempted a deposit with an invalid parameters\")\n Data_encoding.empty\n (function Wrong_deposit_parameters -> Some () | _ -> None)\n (fun () -> Wrong_deposit_parameters) ;\n register_error_kind\n `Permanent\n ~id:\"zk_rollup_ticket_payload_size_limit_exceeded\"\n ~title:\"The payload of the deposited ticket exceeded the size limit\"\n ~description:\"The payload of the deposited ticket exceeded the size limit\"\n Data_encoding.(\n obj2 (req \"payload_size\" Saturation_repr.n_encoding) (req \"limit\" int31))\n (function\n | Ticket_payload_size_limit_exceeded {payload_size; limit} ->\n Some (payload_size, limit)\n | _ -> None)\n (fun (payload_size, limit) ->\n Ticket_payload_size_limit_exceeded {payload_size; limit}) ;\n register_error_kind\n `Temporary\n ~id:\"operation.zk_rollup_failed_verification\"\n ~title:\"Zk_rollup_update: failed verification\"\n ~description:\"Zk_rollup_update: failed verification\"\n ~pp:(fun ppf () -> Format.fprintf ppf \"The proof verification failed\")\n Data_encoding.empty\n (function Invalid_verification -> Some () | _ -> None)\n (fun () -> Invalid_verification) ;\n register_error_kind\n `Permanent\n ~id:\"operation.zk_rollup_invalid_circuit\"\n ~title:\"Zk_rollup_update: invalid circuit\"\n ~description:\"Zk_rollup_update: invalid circuit\"\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"Invalid circuit in proof verification\")\n Data_encoding.empty\n (function Invalid_circuit -> Some () | _ -> None)\n (fun () -> Invalid_circuit) ;\n register_error_kind\n `Permanent\n ~id:\"operation.zk_rollup_inconsistent_state_update\"\n ~title:\"Zk_rollup_update: inconsistent state update\"\n ~description:\"Zk_rollup_update: new state is of incorrect size\"\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"Zk_rollup_update: new state is of incorrect size\")\n Data_encoding.empty\n (function Inconsistent_state_update -> Some () | _ -> None)\n (fun () -> Inconsistent_state_update) ;\n register_error_kind\n `Temporary\n ~id:\"operation.zk_rollup_pending_bound\"\n ~title:\"Zk_rollup_update: update with fewer pending ops than allowed\"\n ~description:\"Zk_rollup_update: update with fewer pending ops than allowed\"\n ~pp:(fun ppf () ->\n Format.fprintf\n ppf\n \"Zk_rollup_update: update with fewer pending ops than allowed\")\n Data_encoding.empty\n (function Pending_bound -> Some () | _ -> None)\n (fun () -> Pending_bound)\n" ;
} ;
{ name = "Destination_storage" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** [must_exist ctxt dest] checks whether the given destination [dest] exists\n in the context [ctxt]. If the destination exists, a new context is returned\n with gas consumed for the lookup cost. If it does not exist, an error is\n returned. *)\nval must_exist :\n Raw_context.t -> Destination_repr.t -> Raw_context.t tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Destination_repr\n\nlet must_exist ctxt =\n let open Lwt_result_syntax in\n function\n | Contract k ->\n let+ () = Contract_storage.must_exist ctxt k in\n ctxt\n | Sc_rollup sc -> Sc_rollup_storage.must_exist ctxt sc\n | Tx_rollup tx -> Tx_rollup_state_storage.assert_exist ctxt tx\n | Zk_rollup zk -> Zk_rollup_storage.assert_exist ctxt zk\n" ;
} ;
{ name = "Alpha_context" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2019-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 TriliTech <contact@trili.tech> *)\n(* Copyright (c) 2022 DaiLambda, Inc. <contact@dailambda,jp> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** An [Alpha_context.t] is an immutable snapshot of the ledger state at some block\n height, preserving\n {{:https://tezos.gitlab.io/developer/entering_alpha.html#the-big-abstraction-barrier-alpha-context}\n type-safety and invariants} of the ledger state.\n\n {2 Implementation}\n\n [Alpha_context.t] is a wrapper over [Raw_context.t], which in turn is a\n wrapper around [Context.t] from the Protocol Environment.\n\n {2 Lifetime of an Alpha_context}\n\n - Creation, using [prepare] or [prepare_first_block]\n\n - Modification, using the operations defined in this signature\n\n - Finalization, using [finalize]\n *)\n\nmodule type BASIC_DATA = sig\n type t\n\n include Compare.S with type t := t\n\n val encoding : t Data_encoding.t\n\n val pp : Format.formatter -> t -> unit\nend\n\ntype t\n\ntype context = t\n\ntype public_key = Signature.Public_key.t\n\ntype public_key_hash = Signature.Public_key_hash.t\n\ntype signature = Signature.t\n\n(** This module re-exports definitions from {!Slot_repr}. *)\nmodule Slot : sig\n type t\n\n type slot = t\n\n include Compare.S with type t := t\n\n val pp : Format.formatter -> t -> unit\n\n val zero : t\n\n val succ : t -> t tzresult\n\n val of_int_do_not_use_except_for_parameters : int -> t\n\n val encoding : t Data_encoding.encoding\n\n module Range : sig\n type t\n\n val create : min:int -> count:int -> t tzresult\n\n val fold : ('a -> slot -> 'a) -> 'a -> t -> 'a\n\n val fold_es :\n ('a -> slot -> 'a tzresult Lwt.t) -> 'a -> t -> 'a tzresult Lwt.t\n\n val rev_fold_es :\n ('a -> slot -> 'a tzresult Lwt.t) -> 'a -> t -> 'a tzresult Lwt.t\n end\n\n module Map : Map.S with type key = t\n\n module Set : Set.S with type elt = t\n\n module Internal_for_tests : sig\n val of_int : int -> t tzresult\n end\nend\n\n(** This module re-exports definitions from {!Tez_repr}. *)\nmodule Tez : sig\n type repr\n\n type t = Tez_tag of repr [@@ocaml.unboxed]\n\n include BASIC_DATA with type t := t\n\n type tez = t\n\n val zero : tez\n\n val one_mutez : tez\n\n val one_cent : tez\n\n val fifty_cents : tez\n\n val one : tez\n\n val ( -? ) : tez -> tez -> tez tzresult\n\n val sub_opt : tez -> tez -> tez option\n\n val ( +? ) : tez -> tez -> tez tzresult\n\n val ( *? ) : tez -> int64 -> tez tzresult\n\n val ( /? ) : tez -> int64 -> tez tzresult\n\n val of_string : string -> tez option\n\n val to_string : tez -> string\n\n val of_mutez : int64 -> tez option\n\n val to_mutez : tez -> int64\n\n val of_mutez_exn : int64 -> t\n\n val mul_exn : t -> int -> t\n\n val div_exn : t -> int -> t\nend\n\n(** This module re-exports definitions from {!Period_repr}. *)\nmodule Period : sig\n include BASIC_DATA\n\n type period = t\n\n val rpc_arg : period RPC_arg.arg\n\n val of_seconds : int64 -> period tzresult\n\n val of_seconds_exn : int64 -> period\n\n val to_seconds : period -> int64\n\n val add : period -> period -> period tzresult\n\n val mult : int32 -> period -> period tzresult\n\n val zero : period\n\n val one_second : period\n\n val one_minute : period\n\n val one_hour : period\n\n val compare : period -> period -> int\nend\n\n(** This module re-exports definitions from {!Time_repr}. *)\nmodule Timestamp : sig\n include BASIC_DATA with type t = Time.t\n\n type time = t\n\n val ( +? ) : time -> Period.t -> time tzresult\n\n val ( -? ) : time -> time -> Period.t tzresult\n\n val ( - ) : time -> Period.t -> time\n\n val of_notation : string -> time option\n\n val to_notation : time -> string\n\n val of_seconds : int64 -> time\n\n val to_seconds : time -> int64\n\n val of_seconds_string : string -> time option\n\n val to_seconds_string : time -> string\n\n (** See {!Raw_context.current_timestamp}. *)\n val current : context -> time\n\n (** See {!Raw_context.predecessor_timestamp}. *)\n val predecessor : context -> time\nend\n\n(** This module re-exports definitions from {!Ratio_repr}. *)\nmodule Ratio : sig\n type t = {numerator : int; denominator : int}\n\n val encoding : t Data_encoding.t\n\n val pp : Format.formatter -> t -> unit\nend\n\n(** This module re-exports definitions from {!Raw_level_repr}. *)\nmodule Raw_level : sig\n include BASIC_DATA\n\n type raw_level = t\n\n val rpc_arg : raw_level RPC_arg.arg\n\n val diff : raw_level -> raw_level -> int32\n\n val root : raw_level\n\n val succ : raw_level -> raw_level\n\n val pred : raw_level -> raw_level option\n\n val to_int32 : raw_level -> int32\n\n val of_int32 : int32 -> raw_level tzresult\n\n val of_int32_exn : int32 -> raw_level\n\n module Set : Set.S with type elt = raw_level\n\n module Map : Map.S with type key = raw_level\n\n module Internal_for_tests : sig\n val add : raw_level -> int -> raw_level\n\n val sub : raw_level -> int -> raw_level option\n end\nend\n\n(** This module re-exports definitions from {!Cycle_repr}. *)\nmodule Cycle : sig\n include BASIC_DATA\n\n type cycle = t\n\n val rpc_arg : cycle RPC_arg.arg\n\n val root : cycle\n\n val succ : cycle -> cycle\n\n val pred : cycle -> cycle option\n\n val add : cycle -> int -> cycle\n\n val sub : cycle -> int -> cycle option\n\n val to_int32 : cycle -> int32\n\n module Map : Map.S with type key = cycle\nend\n\n(** This module re-exports definitions from {!Round_repr}. *)\nmodule Round : sig\n (* A round represents an iteration of the single-shot consensus algorithm.\n This mostly simply re-exports [Round_repr]. See [Round_repr] for\n additional documentation of this module *)\n\n type t\n\n val zero : t\n\n val succ : t -> t\n\n val pred : t -> t tzresult\n\n val to_int32 : t -> int32\n\n val of_int32 : int32 -> t tzresult\n\n val of_int : int -> t tzresult\n\n val to_int : t -> int tzresult\n\n val to_slot : t -> committee_size:int -> Slot.t tzresult\n\n val pp : Format.formatter -> t -> unit\n\n val encoding : t Data_encoding.t\n\n include Compare.S with type t := t\n\n module Map : Map.S with type key = t\n\n (** See {!Round_repr.Durations.t}. *)\n type round_durations\n\n (** See {!Round_repr.Durations.pp}. *)\n val pp_round_durations : Format.formatter -> round_durations -> unit\n\n (** See {!Round_repr.Durations.encoding}. *)\n val round_durations_encoding : round_durations Data_encoding.t\n\n (** See {!Round_repr.Durations.round_duration}. *)\n val round_duration : round_durations -> t -> Period.t\n\n module Durations : sig\n val create :\n first_round_duration:Period.t ->\n delay_increment_per_round:Period.t ->\n round_durations tzresult\n\n val create_opt :\n first_round_duration:Period.t ->\n delay_increment_per_round:Period.t ->\n round_durations option\n end\n\n val level_offset_of_round : round_durations -> round:t -> Period.t tzresult\n\n val timestamp_of_round :\n round_durations ->\n predecessor_timestamp:Time.t ->\n predecessor_round:t ->\n round:t ->\n Time.t tzresult\n\n val timestamp_of_another_round_same_level :\n round_durations ->\n current_timestamp:Time.t ->\n current_round:t ->\n considered_round:t ->\n Time.t tzresult\n\n val round_of_timestamp :\n round_durations ->\n predecessor_timestamp:Time.t ->\n predecessor_round:t ->\n timestamp:Time.t ->\n t tzresult\n\n (* retrieve a round from the context *)\n val get : context -> t tzresult Lwt.t\n\n (* store a round in context *)\n val update : context -> t -> context tzresult Lwt.t\nend\n\nmodule Gas : sig\n (** This module implements the gas subsystem of the context.\n\n Gas reflects the computational cost of each operation to limit\n the cost of operations and, by extension, the cost of blocks.\n\n There are two gas quotas: one for operation and one for\n block. For this reason, we maintain two gas levels -- one for\n operations and another one for blocks -- that correspond to the\n remaining amounts of gas, initialized with the quota\n limits and decreased each time gas is consumed.\n\n *)\n\n module Arith :\n Fixed_point_repr.Safe\n with type 'a t = private Saturation_repr.may_saturate Saturation_repr.t\n\n (** For maintenance operations or for testing, gas can be\n [Unaccounted]. Otherwise, the computation is [Limited] by the\n [remaining] gas in the context. *)\n type t = private Unaccounted | Limited of {remaining : Arith.fp}\n\n val encoding : t Data_encoding.encoding\n\n val pp : Format.formatter -> t -> unit\n\n (** [set_limit ctxt limit] returns a context with a given\n [limit] level of gas allocated for an operation. *)\n val set_limit : context -> 'a Arith.t -> context\n\n (** [set_unlimited] allows unlimited gas consumption. *)\n val set_unlimited : context -> context\n\n (** [remaining_operation_gas ctxt] returns the current gas level in\n the context [ctxt] for the current operation. If gas is\n [Unaccounted], an arbitrary value will be returned. *)\n val remaining_operation_gas : context -> Arith.fp\n\n (** [reset_block_gas ctxt] returns a context where the remaining gas\n in the block is reset to the constant [hard_gas_limit_per_block],\n i.e., as if no operations have been included in the block.\n\n /!\\ Do not call this function unless you want to validate\n operations on their own (like in the mempool). *)\n val reset_block_gas : context -> context\n\n (** [level ctxt] is the current gas level in [ctxt] for the current\n operation. *)\n val level : context -> t\n\n (** [update_remaining_operation_gas ctxt remaining] sets the current\n gas level for operations to [remaining]. *)\n val update_remaining_operation_gas : context -> Arith.fp -> context\n\n (** [consumed since until] is the operation gas level difference\n between context [since] and context [until]. This function\n returns [Arith.zero] if any of the two contexts allows for an\n unlimited gas consumption. This function also returns\n [Arith.zero] if [since] has less gas than [until]. *)\n val consumed : since:context -> until:context -> Arith.fp\n\n (** [block_level ctxt] returns the block gas level in context [ctxt]. *)\n val block_level : context -> Arith.fp\n\n (** Costs are computed using a saturating arithmetic. See\n {!Saturation_repr}. *)\n type cost = Saturation_repr.may_saturate Saturation_repr.t\n\n val cost_encoding : cost Data_encoding.encoding\n\n val pp_cost : Format.formatter -> cost -> unit\n\n val pp_cost_as_gas : Format.formatter -> cost -> unit\n\n type error += Operation_quota_exceeded (* `Temporary *)\n\n (** [consume ctxt cost] subtracts [cost] to the current operation\n gas level in [ctxt]. This operation may fail with\n [Operation_quota_exceeded] if the operation gas level would\n go below zero. *)\n val consume : context -> cost -> context tzresult\n\n (** [consume_from available_gas cost] subtracts [cost] from\n [available_gas] and returns the remaining gas.\n\n @return [Error Operation_quota_exceeded] if the remaining gas\n would fall below [0]. *)\n val consume_from : Arith.fp -> cost -> Arith.fp tzresult\n\n type error += Block_quota_exceeded (* `Temporary *)\n\n type error += Gas_limit_too_high (* `Permanent *)\n\n (** See {!Raw_context.consume_gas_limit_in_block}. *)\n val consume_limit_in_block : context -> 'a Arith.t -> context tzresult\n\n (** Check that [gas_limit] is a valid operation gas limit: at most\n [hard_gas_limit_per_operation] and nonnegative.\n\n @return [Error Gas_limit_too_high] if [gas_limit] is greater\n than [hard_gas_limit_per_operation] or negative. *)\n val check_gas_limit :\n hard_gas_limit_per_operation:Arith.integral ->\n gas_limit:Arith.integral ->\n unit tzresult\n\n (** The cost of free operation is [0]. *)\n val free : cost\n\n (** Convert a fixed-point amount of gas to a cost. *)\n val cost_of_gas : 'a Arith.t -> cost\n\n (** Convert an amount of milligas expressed as an int to Arith.fp. *)\n val fp_of_milligas_int : int -> Arith.fp\n\n (** [atomic_step_cost x] corresponds to [x] milliunit of gas. *)\n val atomic_step_cost : _ Saturation_repr.t -> cost\n\n (** [step_cost x] corresponds to [x] units of gas. *)\n val step_cost : _ Saturation_repr.t -> cost\n\n (** Cost of allocating qwords of storage.\n [alloc_cost n] estimates the cost of allocating [n] qwords of storage. *)\n val alloc_cost : _ Saturation_repr.t -> cost\n\n (** Cost of allocating bytes in the storage.\n [alloc_bytes_cost b] estimates the cost of allocating [b] bytes of\n storage. *)\n val alloc_bytes_cost : int -> cost\n\n (** Cost of allocating bytes in the storage.\n\n [alloc_mbytes_cost b] estimates the cost of allocating [b] bytes of\n storage and the cost of an header to describe these bytes. *)\n val alloc_mbytes_cost : int -> cost\n\n (** Cost of reading the storage.\n [read_bytes_cost n] estimates the cost of reading [n] bytes of storage. *)\n val read_bytes_cost : int -> cost\n\n (** Cost of writing to storage.\n [write_bytes_const n] estimates the cost of writing [n] bytes to the\n storage. *)\n val write_bytes_cost : int -> cost\n\n (** Multiply a cost by a factor. Both arguments are saturated arithmetic values,\n so no negative numbers are involved. *)\n val ( *@ ) : _ Saturation_repr.t -> cost -> cost\n\n (** Add two costs together. *)\n val ( +@ ) : cost -> cost -> cost\n\n (** [cost_of_repr] is an internal operation needed to inject costs\n for Storage_costs into Gas.cost. *)\n val cost_of_repr : Gas_limit_repr.cost -> cost\nend\n\nmodule Entrypoint : module type of Entrypoint_repr\n\n(** This module re-exports definitions from {!Script_repr} and\n {!Michelson_v1_primitives}. *)\nmodule Script : sig\n type error += Lazy_script_decode\n\n type prim = Michelson_v1_primitives.prim =\n | K_parameter\n | K_storage\n | K_code\n | K_view\n | D_False\n | D_Elt\n | D_Left\n | D_None\n | D_Pair\n | D_Right\n | D_Some\n | D_True\n | D_Unit\n | D_Lambda_rec\n | I_PACK\n | I_UNPACK\n | I_BLAKE2B\n | I_SHA256\n | I_SHA512\n | I_ABS\n | I_ADD\n | I_AMOUNT\n | I_AND\n | I_BALANCE\n | I_CAR\n | I_CDR\n | I_CHAIN_ID\n | I_CHECK_SIGNATURE\n | I_COMPARE\n | I_CONCAT\n | I_CONS\n | I_CREATE_ACCOUNT\n | I_CREATE_CONTRACT\n | I_IMPLICIT_ACCOUNT\n | I_DIP\n | I_DROP\n | I_DUP\n | I_VIEW\n | I_EDIV\n | I_EMPTY_BIG_MAP\n | I_EMPTY_MAP\n | I_EMPTY_SET\n | I_EQ\n | I_EXEC\n | I_APPLY\n | I_FAILWITH\n | I_GE\n | I_GET\n | I_GET_AND_UPDATE\n | I_GT\n | I_HASH_KEY\n | I_IF\n | I_IF_CONS\n | I_IF_LEFT\n | I_IF_NONE\n | I_INT\n | I_LAMBDA\n | I_LAMBDA_REC\n | I_LE\n | I_LEFT\n | I_LEVEL\n | I_LOOP\n | I_LSL\n | I_LSR\n | I_LT\n | I_MAP\n | I_MEM\n | I_MUL\n | I_NEG\n | I_NEQ\n | I_NIL\n | I_NONE\n | I_NOT\n | I_NOW\n | I_MIN_BLOCK_TIME\n | I_OR\n | I_PAIR\n | I_UNPAIR\n | I_PUSH\n | I_RIGHT\n | I_SIZE\n | I_SOME\n | I_SOURCE\n | I_SENDER\n | I_SELF\n | I_SELF_ADDRESS\n | I_SLICE\n | I_STEPS_TO_QUOTA\n | I_SUB\n | I_SUB_MUTEZ\n | I_SWAP\n | I_TRANSFER_TOKENS\n | I_SET_DELEGATE\n | I_UNIT\n | I_UPDATE\n | I_XOR\n | I_ITER\n | I_LOOP_LEFT\n | I_ADDRESS\n | I_CONTRACT\n | I_ISNAT\n | I_CAST\n | I_RENAME\n | I_SAPLING_EMPTY_STATE\n | I_SAPLING_VERIFY_UPDATE\n | I_DIG\n | I_DUG\n | I_NEVER\n | I_VOTING_POWER\n | I_TOTAL_VOTING_POWER\n | I_KECCAK\n | I_SHA3\n | I_PAIRING_CHECK\n | I_TICKET\n | I_TICKET_DEPRECATED\n | I_READ_TICKET\n | I_SPLIT_TICKET\n | I_JOIN_TICKETS\n | I_OPEN_CHEST\n | I_EMIT\n | I_BYTES\n | I_NAT\n | T_bool\n | T_contract\n | T_int\n | T_key\n | T_key_hash\n | T_lambda\n | T_list\n | T_map\n | T_big_map\n | T_nat\n | T_option\n | T_or\n | T_pair\n | T_set\n | T_signature\n | T_string\n | T_bytes\n | T_mutez\n | T_timestamp\n | T_unit\n | T_operation\n | T_address\n | T_tx_rollup_l2_address\n | T_sapling_transaction\n | T_sapling_transaction_deprecated\n | T_sapling_state\n | T_chain_id\n | T_never\n | T_bls12_381_g1\n | T_bls12_381_g2\n | T_bls12_381_fr\n | T_ticket\n | T_chest_key\n | T_chest\n | H_constant\n\n type location = Micheline.canonical_location\n\n type annot = Micheline.annot\n\n type expr = prim Micheline.canonical\n\n type lazy_expr = expr Data_encoding.lazy_t\n\n val lazy_expr : expr -> lazy_expr\n\n type 'location michelson_node = ('location, prim) Micheline.node\n\n type node = location michelson_node\n\n type t = {code : lazy_expr; storage : lazy_expr}\n\n val location_encoding : location Data_encoding.t\n\n val expr_encoding : expr Data_encoding.t\n\n val prim_encoding : prim Data_encoding.t\n\n val encoding : t Data_encoding.t\n\n val lazy_expr_encoding : lazy_expr Data_encoding.t\n\n val deserialization_cost_estimated_from_bytes : int -> Gas.cost\n\n val deserialized_cost : expr -> Gas.cost\n\n val micheline_serialization_cost : expr -> Gas.cost\n\n val bytes_node_cost : bytes -> Gas.cost\n\n (** Mode of deserialization gas consumption in {!force_decode}:\n\n - {!Always}: the gas is taken independently of the internal state of the\n [lazy_expr]\n - {!When_needed}: the gas is consumed only if the [lazy_expr] has never\n been deserialized before. *)\n type consume_deserialization_gas = Always | When_needed\n\n (** Decode an expression in the context after consuming the deserialization\n gas cost (see {!consume_deserialization_gas}). *)\n val force_decode_in_context :\n consume_deserialization_gas:consume_deserialization_gas ->\n context ->\n lazy_expr ->\n (expr * context) tzresult\n\n (** Decode an expression in the context after consuming the deserialization\n gas cost. *)\n val force_bytes_in_context :\n context -> lazy_expr -> (bytes * context) tzresult\n\n (** [consume_decoding_gas available_gas lexpr] subtracts (a lower\n bound on) the cost to deserialize [lexpr] from [available_gas].\n The cost does not depend on the internal state of the lazy_expr.\n\n @return [Error Operation_quota_exceeded] if the remaining gas\n would fall below [0].\n\n This mimics the gas consuming part of {!force_decode_in_context}\n called with [consume_deserialization_gas:Always]. *)\n val consume_decoding_gas : Gas.Arith.fp -> lazy_expr -> Gas.Arith.fp tzresult\n\n val unit_parameter : lazy_expr\n\n val strip_locations_cost : _ michelson_node -> Gas.cost\n\n val strip_annotations_cost : node -> Gas.cost\n\n val strip_annotations : node -> node\nend\n\n(** This module re-exports definitions from {!Constants_repr} and\n {!Constants_storage}. *)\nmodule Constants : sig\n (** Fixed constants *)\n type fixed\n\n val fixed_encoding : fixed Data_encoding.t\n\n val mainnet_id : Chain_id.t\n\n val proof_of_work_nonce_size : int\n\n val nonce_length : int\n\n val max_anon_ops_per_block : int\n\n val max_operation_data_length : int\n\n val max_proposals_per_delegate : int\n\n val michelson_maximum_type_size : int\n\n val sc_rollup_message_size_limit : int\n\n val sc_rollup_max_number_of_messages_per_level : Z.t\n\n (** Constants parameterized by context. See {!Constants_parametric_repr}. *)\n module Parametric : sig\n type dal = {\n feature_enable : bool;\n number_of_slots : int;\n attestation_lag : int;\n availability_threshold : int;\n cryptobox_parameters : Dal.parameters;\n }\n\n val dal_encoding : dal Data_encoding.t\n\n type tx_rollup = {\n enable : bool;\n origination_size : int;\n hard_size_limit_per_inbox : int;\n hard_size_limit_per_message : int;\n commitment_bond : Tez.t;\n finality_period : int;\n withdraw_period : int;\n max_inboxes_count : int;\n max_messages_per_inbox : int;\n max_commitments_count : int;\n cost_per_byte_ema_factor : int;\n max_ticket_payload_size : int;\n max_withdrawals_per_batch : int;\n rejection_max_proof_size : int;\n sunset_level : int32;\n }\n\n type sc_rollup = {\n enable : bool;\n arith_pvm_enable : bool;\n origination_size : int;\n challenge_window_in_blocks : int;\n stake_amount : Tez.t;\n commitment_period_in_blocks : int;\n max_lookahead_in_blocks : int32;\n max_active_outbox_levels : int32;\n max_outbox_messages_per_level : int;\n number_of_sections_in_dissection : int;\n timeout_period_in_blocks : int;\n max_number_of_stored_cemented_commitments : int;\n max_number_of_parallel_games : int;\n }\n\n type zk_rollup = {\n enable : bool;\n origination_size : int;\n min_pending_to_process : int;\n }\n\n type t = {\n preserved_cycles : int;\n blocks_per_cycle : int32;\n blocks_per_commitment : int32;\n nonce_revelation_threshold : int32;\n blocks_per_stake_snapshot : int32;\n cycles_per_voting_period : int32;\n hard_gas_limit_per_operation : Gas.Arith.integral;\n hard_gas_limit_per_block : Gas.Arith.integral;\n proof_of_work_threshold : int64;\n minimal_stake : Tez.t;\n vdf_difficulty : int64;\n seed_nonce_revelation_tip : Tez.t;\n origination_size : int;\n baking_reward_fixed_portion : Tez.t;\n baking_reward_bonus_per_slot : Tez.t;\n endorsing_reward_per_slot : Tez.t;\n cost_per_byte : Tez.t;\n hard_storage_limit_per_operation : Z.t;\n quorum_min : int32;\n quorum_max : int32;\n min_proposal_quorum : int32;\n liquidity_baking_subsidy : Tez.t;\n liquidity_baking_toggle_ema_threshold : int32;\n max_operations_time_to_live : int;\n minimal_block_delay : Period.t;\n delay_increment_per_round : Period.t;\n minimal_participation_ratio : Ratio.t;\n consensus_committee_size : int;\n consensus_threshold : int;\n max_slashing_period : int;\n frozen_deposits_percentage : int;\n double_baking_punishment : Tez.t;\n ratio_of_frozen_deposits_slashed_per_double_endorsement : Ratio.t;\n testnet_dictator : public_key_hash option;\n initial_seed : State_hash.t option;\n cache_script_size : int;\n cache_stake_distribution_cycles : int;\n cache_sampler_state_cycles : int;\n tx_rollup : tx_rollup;\n dal : dal;\n sc_rollup : sc_rollup;\n zk_rollup : zk_rollup;\n }\n\n val encoding : t Data_encoding.t\n end\n\n module Generated : sig\n type t = {\n consensus_threshold : int;\n baking_reward_fixed_portion : Tez.t;\n baking_reward_bonus_per_slot : Tez.t;\n endorsing_reward_per_slot : Tez.t;\n liquidity_baking_subsidy : Tez.t;\n }\n\n val generate :\n consensus_committee_size:int -> blocks_per_minute:Ratio.t -> t\n end\n\n val parametric : context -> Parametric.t\n\n val tx_rollup : context -> Parametric.tx_rollup\n\n val sc_rollup : context -> Parametric.sc_rollup\n\n val preserved_cycles : context -> int\n\n val blocks_per_cycle : context -> int32\n\n val blocks_per_commitment : context -> int32\n\n val nonce_revelation_threshold : context -> int32\n\n val blocks_per_stake_snapshot : context -> int32\n\n val cycles_per_voting_period : context -> int32\n\n val hard_gas_limit_per_operation : context -> Gas.Arith.integral\n\n val hard_gas_limit_per_block : context -> Gas.Arith.integral\n\n val cost_per_byte : context -> Tez.t\n\n val hard_storage_limit_per_operation : context -> Z.t\n\n val proof_of_work_threshold : context -> int64\n\n val minimal_stake : context -> Tez.t\n\n val vdf_difficulty : context -> int64\n\n val seed_nonce_revelation_tip : context -> Tez.t\n\n val origination_size : context -> int\n\n val baking_reward_fixed_portion : context -> Tez.t\n\n val baking_reward_bonus_per_slot : context -> Tez.t\n\n val endorsing_reward_per_slot : context -> Tez.t\n\n val quorum_min : context -> int32\n\n val quorum_max : context -> int32\n\n val min_proposal_quorum : context -> int32\n\n val liquidity_baking_subsidy : context -> Tez.t\n\n val liquidity_baking_toggle_ema_threshold : context -> int32\n\n val minimal_block_delay : context -> Period.t\n\n val delay_increment_per_round : context -> Period.t\n\n (** See {!Raw_context.round_durations}. *)\n val round_durations : context -> Round.round_durations\n\n val consensus_committee_size : context -> int\n\n val consensus_threshold : context -> int\n\n val minimal_participation_ratio : context -> Ratio.t\n\n val max_slashing_period : context -> int\n\n val frozen_deposits_percentage : context -> int\n\n val double_baking_punishment : context -> Tez.t\n\n val ratio_of_frozen_deposits_slashed_per_double_endorsement :\n context -> Ratio.t\n\n val testnet_dictator : context -> public_key_hash option\n\n val tx_rollup_enable : context -> bool\n\n val tx_rollup_origination_size : context -> int\n\n val tx_rollup_hard_size_limit_per_inbox : context -> int\n\n val tx_rollup_hard_size_limit_per_message : context -> int\n\n val tx_rollup_max_withdrawals_per_batch : context -> int\n\n val tx_rollup_commitment_bond : context -> Tez.t\n\n val tx_rollup_finality_period : context -> int\n\n val tx_rollup_max_inboxes_count : context -> int\n\n val tx_rollup_max_messages_per_inbox : context -> int\n\n val tx_rollup_max_commitments_count : context -> int\n\n val tx_rollup_max_ticket_payload_size : context -> int\n\n val tx_rollup_rejection_max_proof_size : context -> int\n\n val tx_rollup_sunset_level : context -> int32\n\n val sc_rollup_enable : context -> bool\n\n val sc_rollup_arith_pvm_enable : context -> bool\n\n val dal_enable : context -> bool\n\n val sc_rollup_origination_size : context -> int\n\n val sc_rollup_stake_amount : t -> Tez.t\n\n val sc_rollup_commitment_period_in_blocks : t -> int\n\n val sc_rollup_max_lookahead_in_blocks : t -> int32\n\n val sc_rollup_max_active_outbox_levels : context -> int32\n\n val sc_rollup_max_outbox_messages_per_level : context -> int\n\n val sc_rollup_number_of_sections_in_dissection : context -> int\n\n val max_number_of_stored_cemented_commitments : context -> int\n\n val zk_rollup_enable : context -> bool\n\n val zk_rollup_min_pending_to_process : context -> int\n\n (** All constants: fixed and parametric *)\n type t = private {fixed : fixed; parametric : Parametric.t}\n\n val all : context -> t\n\n val encoding : t Data_encoding.t\nend\n\n(** See the definitions inside the module. *)\nmodule Global_constants_storage : sig\n type error += Expression_too_deep\n\n type error += Expression_already_registered\n\n (** A constant is the prim of the literal characters \"constant\".\n A constant must have a single argument, being a string with a\n well formed hash of a Micheline expression (i.e generated by\n [Script_expr_hash.to_b58check]). *)\n type error += Badly_formed_constant_expression\n\n type error += Nonexistent_global\n\n (** [get context hash] retrieves the Micheline value with the given hash.\n\n Fails with [Nonexistent_global] if no value is found at the given hash.\n\n Fails with [Storage_error Corrupted_data] if the deserialisation fails.\n\n Consumes [Gas_repr.read_bytes_cost <size of the value>]. *)\n val get : t -> Script_expr_hash.t -> (t * Script.expr) tzresult Lwt.t\n\n (** [register context value] Register a constant in the global table of constants,\n returning the hash and storage bytes consumed.\n\n Does not type-check the Micheline code being registered, allow potentially\n ill-typed Michelson values (see note at top of module in global_constants_storage.mli).\n\n The constant is stored unexpanded, but it is temporarily expanded at registration\n time only to check the expanded version respects the following limits.\n\n Fails with [Expression_too_deep] if, after fully, expanding all constants,\n the expression would contain too many nested levels, that is more than\n [Constants_repr.max_allowed_global_constant_depth].\n\n Fails with [Badly_formed_constant_expression] if constants are not\n well-formed (see declaration of [Badly_formed_constant_expression]) or with\n [Nonexistent_global] if a referenced constant does not exist in the table.\n\n Consumes serialization cost.\n Consumes [Gas_repr.write_bytes_cost <size>] where size is the number\n of bytes in the binary serialization provided by [Script.expr_encoding].*)\n val register :\n t -> Script.expr -> (t * Script_expr_hash.t * Z.t) tzresult Lwt.t\n\n (** [expand context expr] Replaces every constant in the\n given Michelson expression with its value stored in the global table.\n\n The expansion is applied recursively so that the returned expression\n contains no constant.\n\n Fails with [Badly_formed_constant_expression] if constants are not\n well-formed (see declaration of [Badly_formed_constant_expression]) or\n with [Nonexistent_global] if a referenced constant does not exist in\n the table. *)\n val expand : t -> Script.expr -> (t * Script.expr) tzresult Lwt.t\n\n (** This module discloses definitions that are only useful for tests and must\n not be used otherwise. *)\n module Internal_for_tests : sig\n (** [node_too_large node] returns true if:\n - The number of sub-nodes in the [node]\n exceeds [Global_constants_storage.node_size_limit].\n - The sum of the bytes in String, Int,\n and Bytes sub-nodes of [node] exceeds\n [Global_constants_storage.bytes_size_limit].\n\n Otherwise returns false. *)\n val node_too_large : Script.node -> bool\n\n (** [bottom_up_fold_cps initial_accumulator node initial_k f]\n folds [node] and all its sub-nodes if any, starting from\n [initial_accumulator], using an initial continuation [initial_k].\n At each node, [f] is called to transform the continuation [k] into\n the next one. This explicit manipulation of the continuation\n is typically useful to short-circuit.\n\n Notice that a common source of bug is to forget to properly call the\n continuation in `f`. *)\n val bottom_up_fold_cps :\n 'accumulator ->\n 'loc Script.michelson_node ->\n ('accumulator -> 'loc Script.michelson_node -> 'return) ->\n ('accumulator ->\n 'loc Script.michelson_node ->\n ('accumulator -> 'loc Script.michelson_node -> 'return) ->\n 'return) ->\n 'return\n\n (** [expr_to_address_in_context context expr] converts [expr]\n into a unique hash represented by a [Script_expr_hash.t].\n\n Consumes gas corresponding to the cost of converting [expr]\n to bytes and hashing the bytes. *)\n val expr_to_address_in_context :\n t -> Script.expr -> (t * Script_expr_hash.t) tzresult\n end\nend\n\n(** This module discloses definitions that are only useful for tests and must\n not be used otherwise. *)\nmodule Internal_for_tests : sig\n val to_raw : context -> Raw_context.t\nend\n\n(** This module re-exports definitions from {!Level_repr} and\n {!Level_storage}. *)\nmodule Level : sig\n type t = private {\n level : Raw_level.t;\n level_position : int32;\n cycle : Cycle.t;\n cycle_position : int32;\n expected_commitment : bool;\n }\n\n include BASIC_DATA with type t := t\n\n val pp_full : Format.formatter -> t -> unit\n\n type level = t\n\n val root : context -> level\n\n val succ : context -> level -> level\n\n val pred : context -> level -> level option\n\n val from_raw : context -> Raw_level.t -> level\n\n (** Fails with [Negative_level_and_offset_sum] if the sum of the raw_level and the offset is negative. *)\n val from_raw_with_offset :\n context -> offset:int32 -> Raw_level.t -> level tzresult\n\n (** [add c level i] i must be positive *)\n val add : context -> level -> int -> level\n\n (** [sub c level i] i must be positive *)\n val sub : context -> level -> int -> level option\n\n val diff : level -> level -> int32\n\n val current : context -> level\n\n val last_level_in_cycle : context -> Cycle.t -> level\n\n val levels_in_cycle : context -> Cycle.t -> level list\n\n val levels_in_current_cycle : context -> ?offset:int32 -> unit -> level list\n\n val last_allowed_fork_level : context -> Raw_level.t\n\n val dawn_of_a_new_cycle : context -> Cycle.t option\n\n val may_snapshot_stake_distribution : context -> bool\n\n val may_compute_randao : context -> bool\nend\n\n(** This module re-exports definitions from {!Fitness_repr}. *)\nmodule Fitness : sig\n type error += Invalid_fitness | Wrong_fitness | Outdated_fitness\n\n type raw = Fitness.t\n\n type t\n\n val encoding : t Data_encoding.t\n\n val pp : Format.formatter -> t -> unit\n\n val create :\n level:Raw_level.t ->\n locked_round:Round.t option ->\n predecessor_round:Round.t ->\n round:Round.t ->\n t tzresult\n\n val create_without_locked_round :\n level:Raw_level.t -> predecessor_round:Round.t -> round:Round.t -> t\n\n val to_raw : t -> raw\n\n val from_raw : raw -> t tzresult\n\n val round_from_raw : raw -> Round.t tzresult\n\n val predecessor_round_from_raw : raw -> Round.t tzresult\n\n val level : t -> Raw_level.t\n\n val round : t -> Round.t\n\n val locked_round : t -> Round.t option\n\n val predecessor_round : t -> Round.t\nend\n\n(** This module re-exports definitions from {!Nonce_storage}. *)\nmodule Nonce : sig\n type t\n\n type nonce = t\n\n val encoding : nonce Data_encoding.t\n\n type unrevealed = {nonce_hash : Nonce_hash.t; delegate : public_key_hash}\n\n val record_hash : context -> unrevealed -> context tzresult Lwt.t\n\n (** See {!Nonce_storage.check_unrevealed}. *)\n val check_unrevealed : context -> Level.t -> nonce -> unit tzresult Lwt.t\n\n val reveal : context -> Level.t -> nonce -> context tzresult Lwt.t\n\n type status = Unrevealed of unrevealed | Revealed of nonce\n\n val get : context -> Level.t -> status tzresult Lwt.t\n\n val of_bytes : bytes -> nonce tzresult\n\n val hash : nonce -> Nonce_hash.t\n\n val check_hash : nonce -> Nonce_hash.t -> bool\nend\n\n(** This module re-exports definitions from {!Seed_repr} and {!Seed_storage}. *)\nmodule Seed : sig\n type seed\n\n val seed_encoding : seed Data_encoding.t\n\n type vdf_solution = Vdf.result * Vdf.proof\n\n val vdf_solution_encoding : vdf_solution Data_encoding.t\n\n val pp_solution : Format.formatter -> vdf_solution -> unit\n\n type vdf_setup = Vdf.discriminant * Vdf.challenge\n\n type error +=\n | Unknown of {oldest : Cycle.t; cycle : Cycle.t; latest : Cycle.t}\n | Already_accepted\n | Unverified_vdf\n | Too_early_revelation\n\n val generate_vdf_setup :\n seed_discriminant:seed -> seed_challenge:seed -> vdf_setup\n\n (** See {!Seed_storage.check_vdf}. *)\n val check_vdf : context -> vdf_solution -> unit tzresult Lwt.t\n\n (** See {!Seed_storage.update_seed}. *)\n val update_seed : context -> vdf_solution -> context tzresult Lwt.t\n\n (** See {!Seed_repr.compare_vdf_solution}. *)\n val compare_vdf_solution : vdf_solution -> vdf_solution -> int\n\n val compute_randao : context -> context tzresult Lwt.t\n\n (* RPC *)\n type seed_computation_status =\n | Nonce_revelation_stage\n | Vdf_revelation_stage of {seed_discriminant : seed; seed_challenge : seed}\n | Computation_finished\n\n val for_cycle : context -> Cycle.t -> seed tzresult Lwt.t\n\n val get_seed_computation_status :\n context -> seed_computation_status tzresult Lwt.t\nend\n\n(** Big maps are a data structure storing key-value associations, just like\n regular maps, but here the whole content of the structure is not loaded in\n memory when interacting with it.\n They are thus suitable for a Michelson contract, for instance, when there are a\n lot of bindings, but only a few items are accessed at each contract call. *)\nmodule Big_map : sig\n (** A big map is referenced in the storage by its identifier. *)\n module Id : sig\n type t = Lazy_storage_kind.Big_map.Id.t\n\n val encoding : t Data_encoding.t\n\n (** Big map argument for a RPC call. *)\n val rpc_arg : t RPC_arg.arg\n\n (** In the protocol, to be used in parse_data only *)\n val parse_z : Z.t -> t\n\n (** In the protocol, to be used in unparse_data only *)\n val unparse_to_z : t -> Z.t\n end\n\n (** Create a fresh big map in the context. *)\n val fresh : temporary:bool -> context -> (context * Id.t) tzresult Lwt.t\n\n (** Carbonated membership of a key (from its hash) in a big map. *)\n val mem :\n context -> Id.t -> Script_expr_hash.t -> (context * bool) tzresult Lwt.t\n\n (** Carbonated retrieval of the value associated to a key (from its hash) in\n a big map, if any. *)\n val get_opt :\n context ->\n Id.t ->\n Script_expr_hash.t ->\n (context * Script.expr option) tzresult Lwt.t\n\n (** Carbonated retrieval of the key and value types of the bindings in a big\n map referenced by its identifier, if this identifier is actually bound to a big map in the context. *)\n val exists :\n context ->\n Id.t ->\n (context * (Script.expr * Script.expr) option) tzresult Lwt.t\n\n (** [list_key_values ?offset ?length ctxt id] lists the key hash and value for\n each entry in big map [id]. The first [offset] values are ignored (if\n passed). Negative offsets are treated as [0]. There will be no more than\n [length] values in the result list (if passed). Negative values are\n treated as [0].\n\n The returned {!context} takes into account gas consumption of traversing\n the keys and loading values. *)\n val list_key_values :\n ?offset:int ->\n ?length:int ->\n context ->\n Id.t ->\n (context * (Script_expr_hash.t * Script.expr) list) tzresult Lwt.t\n\n (** The type of big map updates. When [value = None], the potential binding\n associated to the [key] will be removed. *)\n type update = {\n key : Script_repr.expr;\n (** The key is ignored by an update but is shown in the receipt. *)\n key_hash : Script_expr_hash.t;\n value : Script_repr.expr option;\n }\n\n type updates = update list\n\n (** The types of keys and values in a big map. *)\n type alloc = {key_type : Script_repr.expr; value_type : Script_repr.expr}\nend\n\n(** This module re-exports definitions from {!Sapling_repr}, {!Sapling_storage}\n and {!Sapling_validator}. *)\nmodule Sapling : sig\n (** See {!Sapling_state.Id}. *)\n module Id : sig\n type t\n\n val encoding : t Data_encoding.t\n\n val rpc_arg : t RPC_arg.arg\n\n val parse_z : Z.t -> t (* To be used in parse_data only *)\n\n val unparse_to_z : t -> Z.t (* To be used in unparse_data only *)\n end\n\n (** Create a fresh sapling state in the context. *)\n val fresh : temporary:bool -> context -> (context * Id.t) tzresult Lwt.t\n\n type diff = private {\n commitments_and_ciphertexts :\n (Sapling.Commitment.t * Sapling.Ciphertext.t) list;\n nullifiers : Sapling.Nullifier.t list;\n }\n\n val diff_encoding : diff Data_encoding.t\n\n module Memo_size : sig\n type t\n\n val encoding : t Data_encoding.t\n\n val equal : t -> t -> bool\n\n val parse_z : Z.t -> (t, string) result\n\n val unparse_to_z : t -> Z.t\n\n val in_memory_size : t -> Cache_memory_helpers.sint\n end\n\n type state = private {id : Id.t option; diff : diff; memo_size : Memo_size.t}\n\n (**\n Returns a [state] with fields filled accordingly.\n [id] should only be used by [extract_lazy_storage_updates].\n *)\n val empty_state : ?id:Id.t -> memo_size:Memo_size.t -> unit -> state\n\n type transaction = Sapling.UTXO.transaction\n\n val transaction_encoding : transaction Data_encoding.t\n\n val transaction_get_memo_size : transaction -> Memo_size.t option\n\n (**\n Tries to fetch a state from the storage.\n *)\n val state_from_id : context -> Id.t -> (state * context) tzresult Lwt.t\n\n val rpc_arg : Id.t RPC_arg.t\n\n type root = Sapling.Hash.t\n\n val root_encoding : root Data_encoding.t\n\n (* Function exposed as RPC. Returns the root and a diff of a state starting\n from an optional offset which is zero by default. *)\n val get_diff :\n context ->\n Id.t ->\n ?offset_commitment:Int64.t ->\n ?offset_nullifier:Int64.t ->\n unit ->\n (root * diff) tzresult Lwt.t\n\n val verify_update :\n context ->\n state ->\n transaction ->\n string ->\n (context * (Int64.t * state) option) tzresult Lwt.t\n\n (** See {!Lazy_storage_kind.Sapling_state.alloc}. *)\n type alloc = {memo_size : Memo_size.t}\n\n type updates = diff\n\n val transaction_in_memory_size : transaction -> Cache_memory_helpers.sint\n\n val diff_in_memory_size : diff -> Cache_memory_helpers.sint\n\n module Legacy : sig\n type transaction = Sapling.UTXO.Legacy.transaction\n\n val transaction_encoding : transaction Data_encoding.t\n\n val transaction_get_memo_size : transaction -> Memo_size.t option\n\n val transaction_in_memory_size :\n transaction -> Saturation_repr.may_saturate Saturation_repr.t\n\n val verify_update :\n context ->\n state ->\n transaction ->\n string ->\n (context * (Int64.t * state) option) tzresult Lwt.t\n end\nend\n\n(** This module re-exports definitions from {!Lazy_storage_diff}. *)\nmodule Lazy_storage : sig\n (** This module re-exports definitions from {!Lazy_storage_kind}. *)\n module Kind : sig\n type ('id, 'alloc, 'updates) t =\n | Big_map : (Big_map.Id.t, Big_map.alloc, Big_map.updates) t\n | Sapling_state : (Sapling.Id.t, Sapling.alloc, Sapling.updates) t\n end\n\n (** This module re-exports definitions from {!Lazy_storage_kind.IdSet}. *)\n module IdSet : sig\n type t\n\n type 'acc fold_f = {f : 'i 'a 'u. ('i, 'a, 'u) Kind.t -> 'i -> 'acc -> 'acc}\n\n val empty : t\n\n val mem : ('i, 'a, 'u) Kind.t -> 'i -> t -> bool\n\n val add : ('i, 'a, 'u) Kind.t -> 'i -> t -> t\n\n val diff : t -> t -> t\n\n val fold : ('i, 'a, 'u) Kind.t -> ('i -> 'acc -> 'acc) -> t -> 'acc -> 'acc\n\n val fold_all : 'acc fold_f -> t -> 'acc -> 'acc\n end\n\n type ('id, 'alloc) init = Existing | Copy of {src : 'id} | Alloc of 'alloc\n\n type ('id, 'alloc, 'updates) diff =\n | Remove\n | Update of {init : ('id, 'alloc) init; updates : 'updates}\n\n type diffs_item = private\n | Item :\n ('i, 'a, 'u) Lazy_storage_kind.t * 'i * ('i, 'a, 'u) diff\n -> diffs_item\n\n val make : ('i, 'a, 'u) Kind.t -> 'i -> ('i, 'a, 'u) diff -> diffs_item\n\n type diffs = diffs_item list\n\n val encoding : diffs Data_encoding.t\n\n val diffs_in_memory_size : diffs -> Cache_memory_helpers.nodes_and_size\n\n val cleanup_temporaries : context -> context Lwt.t\n\n val apply : t -> diffs -> (t * Z.t) tzresult Lwt.t\nend\n\n(** See the definitions inside the module. *)\nmodule Origination_nonce : sig\n (** See {!Raw_context.init_origination_nonce}. *)\n val init : context -> Operation_hash.t -> context\n\n (** See {!Raw_context.unset_origination_nonce}. *)\n val unset : context -> context\n\n (** This module discloses definitions that are only useful for tests and must\n not be used otherwise. See {!Origination_nonce}. *)\n module Internal_for_tests : sig\n type t\n\n val initial : Operation_hash.t -> t\n\n val incr : t -> t\n end\nend\n\n(** This module re-exports definitions from {!Ticket_hash_repr}. *)\nmodule Ticket_hash : sig\n type t\n\n val encoding : t Data_encoding.t\n\n val pp : Format.formatter -> t -> unit\n\n val zero : t\n\n val of_script_expr_hash : Script_expr_hash.t -> t\n\n val to_b58check : t -> string\n\n val of_b58check_opt : string -> t option\n\n val of_b58check_exn : string -> t\n\n val of_bytes_exn : bytes -> t\n\n val of_bytes_opt : bytes -> t option\n\n val equal : t -> t -> bool\n\n val compare : t -> t -> int\n\n val make :\n context ->\n ticketer:Script.node ->\n ty:Script.node ->\n contents:Script.node ->\n owner:Script.node ->\n (t * context) tzresult\n\n (** This module discloses definitions that are only useful for tests and must\n not be used otherwise. *)\n module Internal_for_tests : sig\n val make_uncarbonated :\n ticketer:Script.node ->\n ty:Script.node ->\n contents:Script.node ->\n owner:Script.node ->\n t tzresult\n end\nend\n\n(** This module re-exports definitions from {!Manager_counter_repr}. *)\nmodule Manager_counter : sig\n include Compare.S\n\n val succ : t -> t\n\n val pp : Format.formatter -> t -> unit\n\n val encoding_for_RPCs : t Data_encoding.t\n\n module Internal_for_injection : sig\n val of_string : string -> t option\n end\n\n module Internal_for_tests : sig\n val of_int : int -> t\n\n val to_int : t -> int\n\n val add : t -> int -> t\n end\nend\n\n(** This module re-exports definitions from {!Contract_repr} and\n {!Contract_storage}. *)\nmodule Contract : sig\n type t = Implicit of public_key_hash | Originated of Contract_hash.t\n\n (** Functions related to contracts address. *)\n\n type error += Non_existing_contract of t\n\n include BASIC_DATA with type t := t\n\n val implicit_encoding : public_key_hash Data_encoding.t\n\n val originated_encoding : Contract_hash.t Data_encoding.t\n\n val in_memory_size : t -> Cache_memory_helpers.sint\n\n val rpc_arg : t RPC_arg.arg\n\n val to_b58check : t -> string\n\n val of_b58check : string -> t tzresult\n\n (** Functions related to contracts existence. *)\n\n val exists : context -> t -> bool Lwt.t\n\n val must_exist : context -> t -> unit tzresult Lwt.t\n\n val allocated : context -> t -> bool Lwt.t\n\n val must_be_allocated : context -> t -> unit tzresult Lwt.t\n\n val list : context -> t list Lwt.t\n\n (** Functions related to both implicit accounts and originated contracts. *)\n\n (** See {!Contract_storage.get_balance}. *)\n val get_balance : context -> t -> Tez.t tzresult Lwt.t\n\n val get_balance_carbonated : context -> t -> (context * Tez.t) tzresult Lwt.t\n\n val get_frozen_bonds : context -> t -> Tez.t tzresult Lwt.t\n\n val get_balance_and_frozen_bonds : context -> t -> Tez.t tzresult Lwt.t\n\n (** Functions related to implicit accounts. *)\n\n (** See {!Contract_manager_storage.get_manager_key}. *)\n val get_manager_key :\n ?error:error -> context -> public_key_hash -> public_key tzresult Lwt.t\n\n (** See {!Contract_manager_storage.is_manager_key_revealed}. *)\n val is_manager_key_revealed :\n context -> public_key_hash -> bool tzresult Lwt.t\n\n (** See {!Contract_manager_storage.check_public_key}. *)\n val check_public_key : public_key -> public_key_hash -> unit tzresult\n\n (** See {!Contract_manager_storage.reveal_manager_key}. *)\n val reveal_manager_key :\n ?check_consistency:bool ->\n context ->\n public_key_hash ->\n public_key ->\n context tzresult Lwt.t\n\n val get_counter :\n context -> public_key_hash -> Manager_counter.t tzresult Lwt.t\n\n val increment_counter : context -> public_key_hash -> context tzresult Lwt.t\n\n val check_counter_increment :\n context -> public_key_hash -> Manager_counter.t -> unit tzresult Lwt.t\n\n (** See {!Contract_storage.check_allocated_and_get_balance}. *)\n val check_allocated_and_get_balance :\n context -> public_key_hash -> Tez.t tzresult Lwt.t\n\n (** See {!Contract_storage.simulate_spending}. *)\n val simulate_spending :\n context ->\n balance:Tez.t ->\n amount:Tez.t ->\n public_key_hash ->\n (Tez.t * bool) tzresult Lwt.t\n\n (** Functions related to smart contracts. *)\n\n val get_script_code :\n context ->\n Contract_hash.t ->\n (context * Script.lazy_expr option) tzresult Lwt.t\n\n val get_script :\n context -> Contract_hash.t -> (context * Script.t option) tzresult Lwt.t\n\n val get_storage :\n context -> Contract_hash.t -> (context * Script.expr option) tzresult Lwt.t\n\n val used_storage_space : context -> t -> Z.t tzresult Lwt.t\n\n val paid_storage_space : context -> t -> Z.t tzresult Lwt.t\n\n val increase_paid_storage :\n context -> Contract_hash.t -> amount_in_bytes:Z.t -> context tzresult Lwt.t\n\n val fresh_contract_from_current_nonce :\n context -> (context * Contract_hash.t) tzresult\n\n val originated_from_current_nonce :\n since:context -> until:context -> Contract_hash.t list tzresult Lwt.t\n\n val update_script_storage :\n context ->\n Contract_hash.t ->\n Script.expr ->\n Lazy_storage.diffs option ->\n context tzresult Lwt.t\n\n val raw_originate :\n context ->\n prepaid_bootstrap_storage:bool ->\n Contract_hash.t ->\n script:Script.t * Lazy_storage.diffs option ->\n context tzresult Lwt.t\n\n module Legacy_big_map_diff : sig\n type item = private\n | Update of {\n big_map : Z.t;\n diff_key : Script.expr;\n diff_key_hash : Script_expr_hash.t;\n diff_value : Script.expr option;\n }\n | Clear of Z.t\n | Copy of {src : Z.t; dst : Z.t}\n | Alloc of {\n big_map : Z.t;\n key_type : Script.expr;\n value_type : Script.expr;\n }\n\n type t = private item list\n\n val of_lazy_storage_diff : Lazy_storage.diffs -> t\n end\n\n (** Functions for handling the delegate of a contract.*)\n module Delegate : sig\n (** See {!Contract_delegate_storage.find}. *)\n val find : context -> t -> public_key_hash option tzresult Lwt.t\n\n (** See {!Delegate_storage.Contract.init}. *)\n val init : context -> t -> public_key_hash -> context tzresult Lwt.t\n\n (** See {!Delegate_storage.Contract.set}. *)\n val set : context -> t -> public_key_hash option -> context tzresult Lwt.t\n end\n\n (** This module discloses definitions that are only useful for tests and must\n not be used otherwise. *)\n module Internal_for_tests : sig\n (** See {!Contract_repr.originated_contract}. *)\n val originated_contract : Origination_nonce.Internal_for_tests.t -> t\n\n val paid_storage_space : context -> t -> Z.t tzresult Lwt.t\n end\nend\n\n(** This module re-exports definitions from {!Tx_rollup_level_repr}. *)\nmodule Tx_rollup_level : sig\n include BASIC_DATA\n\n type level = t\n\n val rpc_arg : level RPC_arg.arg\n\n val diff : level -> level -> int32\n\n val root : level\n\n val succ : level -> level\n\n val pred : level -> level option\n\n val to_int32 : level -> int32\n\n val of_int32 : int32 -> level tzresult\nend\n\n(** This module re-exports definitions from {!Tx_rollup_repr} and\n {!Tx_rollup_storage}. *)\nmodule Tx_rollup : sig\n include BASIC_DATA\n\n val in_memory_size : t -> Cache_memory_helpers.sint\n\n val rpc_arg : t RPC_arg.arg\n\n val to_b58check : t -> string\n\n val of_b58check : string -> t tzresult\n\n val of_b58check_opt : string -> t option\n\n val pp : Format.formatter -> t -> unit\n\n val encoding : t Data_encoding.t\n\n val originate : context -> (context * t) tzresult Lwt.t\n\n module Set : Set.S with type elt = t\n\n (** This module discloses definitions that are only useful for tests and must\n not be used otherwise. *)\n module Internal_for_tests : sig\n (** See {!Tx_rollup_repr.originated_tx_rollup}. *)\n val originated_tx_rollup : Origination_nonce.Internal_for_tests.t -> t\n end\nend\n\n(** This module re-exports definitions from {!Tx_rollup_withdraw_repr}. *)\nmodule Tx_rollup_withdraw : sig\n type order = {\n claimer : public_key_hash;\n ticket_hash : Ticket_hash.t;\n amount : Tx_rollup_l2_qty.t;\n }\n\n type t = order\n\n val encoding : t Data_encoding.t\nend\n\n(** This module re-exports definitions from\n {!Tx_rollup_withdraw_list_hash_repr}. *)\nmodule Tx_rollup_withdraw_list_hash : sig\n include S.HASH\n\n val hash_uncarbonated : Tx_rollup_withdraw.t list -> t\n\n val empty : t\nend\n\n(** This module re-exports definitions from {!Tx_rollup_message_result_repr}. *)\nmodule Tx_rollup_message_result : sig\n type t = {\n context_hash : Context_hash.t;\n withdraw_list_hash : Tx_rollup_withdraw_list_hash.t;\n }\n\n val encoding : t Data_encoding.t\n\n val empty_l2_context_hash : Context_hash.t\n\n val init : t\nend\n\n(** This module re-exports definitions from\n {!Tx_rollup_message_result_hash_repr}. *)\nmodule Tx_rollup_message_result_hash : sig\n include S.HASH\n\n val hash_uncarbonated : Tx_rollup_message_result.t -> t\n\n val init : t\nend\n\n(** This module re-exports definitions from {!Tx_rollup_commitment_repr.Hash}.\n*)\nmodule Tx_rollup_commitment_hash : sig\n val commitment_hash : string\n\n include S.HASH\nend\n\n(** This module re-exports definitions from {!Tx_rollup_state_repr}\n and {!Tx_rollup_state_storage}. *)\nmodule Tx_rollup_state : sig\n type t\n\n val initial_state : pre_allocated_storage:Z.t -> t\n\n val encoding : t Data_encoding.t\n\n val pp : Format.formatter -> t -> unit\n\n val find : context -> Tx_rollup.t -> (context * t option) tzresult Lwt.t\n\n val get : context -> Tx_rollup.t -> (context * t) tzresult Lwt.t\n\n val update : context -> Tx_rollup.t -> t -> context tzresult Lwt.t\n\n val burn_cost : limit:Tez.t option -> t -> int -> Tez.t tzresult\n\n val assert_exist : context -> Tx_rollup.t -> context tzresult Lwt.t\n\n val head_levels : t -> (Tx_rollup_level.t * Raw_level.t) option\n\n val check_level_can_be_rejected : t -> Tx_rollup_level.t -> unit tzresult\n\n val last_removed_commitment_hashes :\n t -> (Tx_rollup_message_result_hash.t * Tx_rollup_commitment_hash.t) option\n\n val adjust_storage_allocation : t -> delta:Z.t -> (t * Z.t) tzresult\n\n (** This module discloses definitions that are only useful for tests and must\n not be used otherwise. *)\n module Internal_for_tests : sig\n val make :\n ?burn_per_byte:Tez.t ->\n ?inbox_ema:int ->\n ?last_removed_commitment_hashes:\n Tx_rollup_message_result_hash.t * Tx_rollup_commitment_hash.t ->\n ?finalized_commitments:Tx_rollup_level.t * Tx_rollup_level.t ->\n ?unfinalized_commitments:Tx_rollup_level.t * Tx_rollup_level.t ->\n ?uncommitted_inboxes:Tx_rollup_level.t * Tx_rollup_level.t ->\n ?commitment_newest_hash:Tx_rollup_commitment_hash.t ->\n ?tezos_head_level:Raw_level.t ->\n ?occupied_storage:Z.t ->\n ?commitments_watermark:Tx_rollup_level.t ->\n allocated_storage:Z.t ->\n unit ->\n t\n\n val update_burn_per_byte :\n t -> elapsed:int -> factor:int -> final_size:int -> hard_limit:int -> t\n\n val get_inbox_ema : t -> int\n\n val record_inbox_deletion : t -> Tx_rollup_level.t -> t tzresult\n\n val get_occupied_storage : t -> Z.t\n\n val set_occupied_storage : Z.t -> t -> t\n\n val get_allocated_storage : t -> Z.t\n\n val set_allocated_storage : Z.t -> t -> t\n\n val next_commitment_level : t -> Raw_level.t -> Tx_rollup_level.t tzresult\n\n val uncommitted_inboxes_count : t -> int\n\n val reset_commitments_watermark : t -> t\n\n val get_commitments_watermark : t -> Tx_rollup_level.t option\n end\nend\n\n(** This module re-exports definitions from {!Tx_rollup_reveal_repr} and\n {!Tx_rollup_reveal_storage}. *)\nmodule Tx_rollup_reveal : sig\n type t = {\n contents : Script.lazy_expr;\n ty : Script.lazy_expr;\n ticketer : Contract.t;\n amount : Tx_rollup_l2_qty.t;\n claimer : public_key_hash;\n }\n\n val encoding : t Data_encoding.t\n\n val record :\n context ->\n Tx_rollup.t ->\n Tx_rollup_level.t ->\n message_position:int ->\n context tzresult Lwt.t\n\n val mem :\n context ->\n Tx_rollup.t ->\n Tx_rollup_level.t ->\n message_position:int ->\n (context * bool) tzresult Lwt.t\n\n val remove :\n context -> Tx_rollup.t -> Tx_rollup_level.t -> context tzresult Lwt.t\nend\n\n(** This module re-exports definitions from {!Tx_rollup_message_repr}. *)\nmodule Tx_rollup_message : sig\n type deposit = {\n sender : public_key_hash;\n destination : Tx_rollup_l2_address.Indexable.value;\n ticket_hash : Ticket_hash.t;\n amount : Tx_rollup_l2_qty.t;\n }\n\n type t = private Batch of string | Deposit of deposit\n\n (** [make_batch batch] creates a new [Batch] message to be added that can be\n added to an inbox, along with its size in bytes. See\n {!Tx_rollup_message_repr.size}. *)\n val make_batch : string -> t * int\n\n (** [make_deposit destination ticket_hash qty] creates a new\n [Deposit] message to be added that can be added to an inbox,\n along with its size in bytes. See\n {!Tx_rollup_message_repr.size}. *)\n val make_deposit :\n public_key_hash ->\n Tx_rollup_l2_address.t Indexable.value ->\n Ticket_hash.t ->\n Tx_rollup_l2_qty.t ->\n t * int\n\n val encoding : t Data_encoding.t\n\n val pp : Format.formatter -> t -> unit\nend\n\n(** This module re-exports definitions from {!Tx_rollup_message_hash_repr}. *)\nmodule Tx_rollup_message_hash : sig\n include S.HASH\n\n val hash_uncarbonated : Tx_rollup_message.t -> t\nend\n\n(** This module re-exports definitions from {!Tx_rollup_inbox_repr} and\n {!Tx_rollup_inbox_storage}. *)\nmodule Tx_rollup_inbox : sig\n module Merkle : sig\n type root\n\n type path\n\n val path_encoding : path Data_encoding.t\n\n val root_encoding : root Data_encoding.t\n\n val root_of_b58check_opt : string -> root option\n\n val compute_path : Tx_rollup_message_hash.t list -> int -> path tzresult\n\n val merklize_list : Tx_rollup_message_hash.t list -> root\n\n val path_depth : path -> int\n end\n\n type t = {inbox_length : int; cumulated_size : int; merkle_root : Merkle.root}\n\n val size : Z.t\n\n val ( = ) : t -> t -> bool\n\n val pp : Format.formatter -> t -> unit\n\n val encoding : t Data_encoding.t\n\n val append_message :\n context ->\n Tx_rollup.t ->\n Tx_rollup_state.t ->\n Tx_rollup_message.t ->\n (context * Tx_rollup_state.t * Z.t) tzresult Lwt.t\n\n val get :\n context -> Tx_rollup_level.t -> Tx_rollup.t -> (context * t) tzresult Lwt.t\n\n val find :\n context ->\n Tx_rollup_level.t ->\n Tx_rollup.t ->\n (context * t option) tzresult Lwt.t\n\n val check_message_hash :\n context ->\n Tx_rollup_level.t ->\n Tx_rollup.t ->\n position:int ->\n Tx_rollup_message.t ->\n Merkle.path ->\n context tzresult Lwt.t\nend\n\n(** This module re-exports definitions from {!Tx_rollup_commitment_repr}. *)\nmodule Tx_rollup_commitment : sig\n module Merkle_hash : S.HASH\n\n module Merkle :\n Merkle_list.T\n with type elt = Tx_rollup_message_result_hash.t\n and type h = Merkle_hash.t\n\n type 'a template = {\n level : Tx_rollup_level.t;\n messages : 'a;\n predecessor : Tx_rollup_commitment_hash.t option;\n inbox_merkle_root : Tx_rollup_inbox.Merkle.root;\n }\n\n module Compact : sig\n type excerpt = {\n count : int;\n root : Merkle.h;\n last_result_message_hash : Tx_rollup_message_result_hash.t;\n }\n\n type t = excerpt template\n\n val pp : Format.formatter -> t -> unit\n\n val encoding : t Data_encoding.t\n\n val hash : t -> Tx_rollup_commitment_hash.t\n end\n\n module Submitted_commitment : sig\n type nonrec t = {\n commitment : Compact.t;\n commitment_hash : Tx_rollup_commitment_hash.t;\n committer : public_key_hash;\n submitted_at : Raw_level.t;\n finalized_at : Raw_level.t option;\n }\n\n val encoding : t Data_encoding.t\n end\n\n module Full : sig\n type t = Tx_rollup_message_result_hash.t list template\n\n val encoding : t Data_encoding.t\n\n val pp : Format.formatter -> t -> unit\n\n val compact : t -> Compact.t\n end\n\n val check_message_result :\n context ->\n Compact.t ->\n [ `Hash of Tx_rollup_message_result_hash.t\n | `Result of Tx_rollup_message_result.t ] ->\n path:Merkle.path ->\n index:int ->\n context tzresult\n\n val add_commitment :\n context ->\n Tx_rollup.t ->\n Tx_rollup_state.t ->\n public_key_hash ->\n Full.t ->\n (context * Tx_rollup_state.t * public_key_hash option) tzresult Lwt.t\n\n val find :\n context ->\n Tx_rollup.t ->\n Tx_rollup_state.t ->\n Tx_rollup_level.t ->\n (context * Submitted_commitment.t option) tzresult Lwt.t\n\n val get :\n context ->\n Tx_rollup.t ->\n Tx_rollup_state.t ->\n Tx_rollup_level.t ->\n (context * Submitted_commitment.t) tzresult Lwt.t\n\n val check_agreed_and_disputed_results :\n context ->\n Tx_rollup.t ->\n Tx_rollup_state.t ->\n Submitted_commitment.t ->\n agreed_result:Tx_rollup_message_result.t ->\n agreed_result_path:Merkle.path ->\n disputed_result:Tx_rollup_message_result_hash.t ->\n disputed_position:int ->\n disputed_result_path:Merkle.path ->\n context tzresult Lwt.t\n\n val get_finalized :\n context ->\n Tx_rollup.t ->\n Tx_rollup_state.t ->\n Tx_rollup_level.t ->\n (context * Submitted_commitment.t) tzresult Lwt.t\n\n val pending_bonded_commitments :\n context -> Tx_rollup.t -> public_key_hash -> (context * int) tzresult Lwt.t\n\n val has_bond :\n context -> Tx_rollup.t -> public_key_hash -> (context * bool) tzresult Lwt.t\n\n val finalize_commitment :\n context ->\n Tx_rollup.t ->\n Tx_rollup_state.t ->\n (context * Tx_rollup_state.t * Tx_rollup_level.t) tzresult Lwt.t\n\n val remove_commitment :\n context ->\n Tx_rollup.t ->\n Tx_rollup_state.t ->\n (context * Tx_rollup_state.t * Tx_rollup_level.t) tzresult Lwt.t\n\n val remove_bond :\n context -> Tx_rollup.t -> public_key_hash -> context tzresult Lwt.t\n\n val slash_bond :\n context -> Tx_rollup.t -> public_key_hash -> (context * bool) tzresult Lwt.t\n\n val reject_commitment :\n context ->\n Tx_rollup.t ->\n Tx_rollup_state.t ->\n Tx_rollup_level.t ->\n (context * Tx_rollup_state.t) tzresult Lwt.t\nend\n\n(** This module re-exports definitions from {!Tx_rollup_hash_builder}. *)\nmodule Tx_rollup_hash : sig\n val message_result :\n context ->\n Tx_rollup_message_result.t ->\n (context * Tx_rollup_message_result_hash.t) tzresult\n\n val compact_commitment :\n context ->\n Tx_rollup_commitment.Compact.t ->\n (context * Tx_rollup_commitment_hash.t) tzresult\n\n val withdraw_list :\n context ->\n Tx_rollup_withdraw.t list ->\n (context * Tx_rollup_withdraw_list_hash.t) tzresult\nend\n\n(** This module re-exports definitions from {!Tx_rollup_errors_repr}. *)\nmodule Tx_rollup_errors : sig\n type error +=\n | Tx_rollup_already_exists of Tx_rollup.t\n | Tx_rollup_does_not_exist of Tx_rollup.t\n | Submit_batch_burn_exceeded of {burn : Tez.t; limit : Tez.t}\n | Inbox_does_not_exist of Tx_rollup.t * Tx_rollup_level.t\n | Inbox_size_would_exceed_limit of Tx_rollup.t\n | Inbox_count_would_exceed_limit of Tx_rollup.t\n | Message_size_exceeds_limit\n | Too_many_inboxes\n | Too_many_commitments\n | Too_many_withdrawals\n | Wrong_batch_count\n | Commitment_too_early of {\n provided : Tx_rollup_level.t;\n expected : Tx_rollup_level.t;\n }\n | Level_already_has_commitment of Tx_rollup_level.t\n | Wrong_inbox_hash\n | Bond_does_not_exist of public_key_hash\n | Bond_in_use of public_key_hash\n | No_uncommitted_inbox\n | No_commitment_to_finalize\n | No_commitment_to_remove\n | Invalid_committer\n | Remove_commitment_too_early\n | Commitment_does_not_exist of Tx_rollup_level.t\n | Wrong_predecessor_hash of {\n provided : Tx_rollup_commitment_hash.t option;\n expected : Tx_rollup_commitment_hash.t option;\n }\n | Internal_error of string\n | Wrong_message_position of {\n level : Tx_rollup_level.t;\n position : int;\n length : int;\n }\n | Wrong_path_depth of {\n kind : [`Inbox | `Commitment];\n provided : int;\n limit : int;\n }\n | Wrong_message_path of {expected : Tx_rollup_inbox.Merkle.root}\n | No_finalized_commitment_for_level of {\n level : Tx_rollup_level.t;\n window : (Tx_rollup_level.t * Tx_rollup_level.t) option;\n }\n | Withdraw_invalid_path\n | Withdraw_already_consumed\n | Withdrawals_invalid_path\n | Withdrawals_already_dispatched\n | Cannot_reject_level of {\n provided : Tx_rollup_level.t;\n accepted_range : (Tx_rollup_level.t * Tx_rollup_level.t) option;\n }\n | Wrong_rejection_hash of {\n provided : Tx_rollup_message_result_hash.t;\n expected :\n [ `Valid_path of Tx_rollup_commitment.Merkle.h * int\n | `Hash of Tx_rollup_message_result_hash.t ];\n }\n | Proof_undecodable\n | Proof_failed_to_reject\n | Proof_produced_rejected_state\n | Proof_invalid_before of {\n agreed : Context_hash.t;\n provided : Context_hash.t;\n }\n | No_withdrawals_to_dispatch\n\n val check_path_depth :\n [`Inbox | `Commitment] -> int -> count_limit:int -> unit tzresult\nend\n\n(** This is a forward declaration to avoid circular dependencies.\n Use module [Sc_rollup] instead whenever possible.\n TODO : find a better way to resolve the circular dependency\n https://gitlab.com/tezos/tezos/-/issues/3147 *)\nmodule Sc_rollup_repr : sig\n module Address : S.HASH\n\n type t = Address.t\nend\n\n(** This module re-exports definitions from {!Bond_id_repr}. *)\nmodule Bond_id : sig\n type t =\n | Tx_rollup_bond_id of Tx_rollup.t\n | Sc_rollup_bond_id of Sc_rollup_repr.t\n\n val pp : Format.formatter -> t -> unit\n\n val compare : t -> t -> int\n\n (** This module discloses definitions that are only useful for tests and must\n not be used otherwise. *)\n module Internal_for_tests : sig\n val fold_on_bond_ids :\n context ->\n Contract.t ->\n order:[`Sorted | `Undefined] ->\n init:'a ->\n f:(t -> 'a -> 'a Lwt.t) ->\n 'a Lwt.t\n end\nend\n\n(** This module re-exports definitions from {!Zk_rollup_repr} and\n {!Zk_rollup_storage}. *)\nmodule Zk_rollup : sig\n module Address : S.HASH\n\n type t = Address.t\n\n type scalar := Bls.Primitive.Fr.t\n\n val to_scalar : t -> scalar\n\n (** This module re-exports definitions from {!Zk_rollup_state_repr}. *)\n module State : sig\n type t = scalar array\n\n val encoding : t Data_encoding.t\n end\n\n (** This module re-exports definitions from {!Zk_rollup_account_repr}. *)\n module Account : sig\n module SMap : Map.S with type key = string\n\n type static = {\n public_parameters : Plonk.public_parameters;\n state_length : int;\n circuits_info : [`Public | `Private | `Fee] SMap.t;\n nb_ops : int;\n }\n\n type dynamic = {\n state : State.t;\n paid_l2_operations_storage_space : Z.t;\n used_l2_operations_storage_space : Z.t;\n }\n\n type t = {static : static; dynamic : dynamic}\n\n val encoding : t Data_encoding.t\n\n val circuits_info_encoding :\n [`Public | `Private | `Fee] SMap.t Data_encoding.t\n end\n\n (** This module re-exports definitions from {!Zk_rollup_operation_repr}. *)\n module Operation : sig\n type price = {id : Ticket_hash.t; amount : Z.t}\n\n type t = {\n op_code : int;\n price : price;\n l1_dst : Signature.Public_key_hash.t;\n rollup_id : Address.t;\n payload : scalar array;\n }\n\n val encoding : t Data_encoding.t\n\n val to_scalar_array : t -> scalar array\n end\n\n module Ticket : sig\n type t = {contents : Script.expr; ty : Script.expr; ticketer : Contract.t}\n\n val encoding : t Data_encoding.t\n end\n\n module Circuit_public_inputs : sig\n type pending_op_public_inputs = {\n old_state : State.t;\n new_state : State.t;\n fee : scalar;\n exit_validity : bool;\n zk_rollup : t;\n l2_op : Operation.t;\n }\n\n type private_batch_public_inputs = {\n old_state : State.t;\n new_state : State.t;\n fees : scalar;\n zk_rollup : t;\n }\n\n type fee_public_inputs = {\n old_state : State.t;\n new_state : State.t;\n fees : scalar;\n }\n\n type t =\n | Pending_op of pending_op_public_inputs\n | Private_batch of private_batch_public_inputs\n | Fee of fee_public_inputs\n\n val to_scalar_array : t -> scalar array\n end\n\n module Update : sig\n type op_pi = {new_state : State.t; fee : scalar; exit_validity : bool}\n\n type private_inner_pi = {new_state : State.t; fees : scalar}\n\n type fee_pi = {new_state : State.t}\n\n type t = {\n pending_pis : (string * op_pi) list;\n private_pis : (string * private_inner_pi) list;\n fee_pi : fee_pi;\n proof : Plonk.proof;\n }\n\n val encoding : t Data_encoding.t\n end\n\n type pending_list =\n | Empty of {next_index : int64}\n | Pending of {next_index : int64; length : int}\n\n val pending_list_encoding : pending_list Data_encoding.t\n\n val in_memory_size : t -> Cache_memory_helpers.sint\n\n val originate :\n context ->\n Account.static ->\n init_state:State.t ->\n (context * Address.t * Z.t) tzresult Lwt.t\n\n val add_to_pending :\n context ->\n Address.t ->\n (Operation.t * Ticket_hash.t option) list ->\n (context * Z.t) tzresult Lwt.t\n\n val get_pending_length :\n context -> Address.t -> (context * int) tzresult Lwt.t\n\n val get_prefix :\n context ->\n Address.t ->\n int ->\n (context * (Operation.t * Ticket_hash.t option) list) tzresult Lwt.t\n\n val update :\n context ->\n Address.t ->\n pending_to_drop:int ->\n new_account:Account.t ->\n context tzresult Lwt.t\n\n val account : context -> t -> (context * Account.t) tzresult Lwt.t\n\n val pending_list : context -> t -> (context * pending_list) tzresult Lwt.t\n\n val pending_op :\n context ->\n t ->\n Int64.t ->\n (context * (Operation.t * Ticket_hash.t option)) tzresult Lwt.t\n\n val assert_exist : context -> t -> context tzresult Lwt.t\n\n val exists : context -> t -> (context * bool) tzresult Lwt.t\n\n module Errors : sig\n type error +=\n | Deposit_as_external\n | Invalid_deposit_amount\n | Invalid_deposit_ticket\n | Wrong_deposit_parameters\n | Ticket_payload_size_limit_exceeded of {\n payload_size : Saturation_repr.may_saturate Saturation_repr.t;\n limit : int;\n }\n | Invalid_verification\n | Invalid_circuit\n | Inconsistent_state_update\n | Pending_bound\n end\n\n module Internal_for_tests : sig\n val originated_zk_rollup : Origination_nonce.Internal_for_tests.t -> t\n end\nend\n\n(** This module re-exports definitions from {!Receipt_repr}. *)\nmodule Receipt : sig\n type balance =\n | Contract of Contract.t\n | Block_fees\n | Deposits of public_key_hash\n | Nonce_revelation_rewards\n | Double_signing_evidence_rewards\n | Endorsing_rewards\n | Baking_rewards\n | Baking_bonuses\n | Storage_fees\n | Double_signing_punishments\n | Lost_endorsing_rewards of public_key_hash * bool * bool\n | Liquidity_baking_subsidies\n | Burned\n | Commitments of Blinded_public_key_hash.t\n | Bootstrap\n | Invoice\n | Initial_commitments\n | Minted\n | Frozen_bonds of Contract.t * Bond_id.t\n | Tx_rollup_rejection_punishments\n | Tx_rollup_rejection_rewards\n | Sc_rollup_refutation_punishments\n | Sc_rollup_refutation_rewards\n\n val compare_balance : balance -> balance -> int\n\n type balance_update = Debited of Tez.t | Credited of Tez.t\n\n type update_origin =\n | Block_application\n | Protocol_migration\n | Subsidy\n | Simulation\n\n val compare_update_origin : update_origin -> update_origin -> int\n\n type balance_updates = (balance * balance_update * update_origin) list\n\n val balance_updates_encoding : balance_updates Data_encoding.t\n\n val group_balance_updates : balance_updates -> balance_updates tzresult\nend\n\n(** This module re-exports definitions from {!Delegate_consensus_key}. *)\nmodule Consensus_key : sig\n type pk = {\n delegate : Signature.Public_key_hash.t;\n consensus_pk : Signature.Public_key.t;\n consensus_pkh : Signature.Public_key_hash.t;\n }\n\n type t = {\n delegate : Signature.Public_key_hash.t;\n consensus_pkh : Signature.Public_key_hash.t;\n }\n\n val zero : t\n\n val pp : Format.formatter -> t -> unit\n\n val pkh : pk -> t\nend\n\n(** This module re-exports definitions from {!Delegate_storage},\n {!Delegate_consensus_key}, {!Delegate_missed_endorsements_storage},\n {!Delegate_slashed_deposits_storage}, {!Delegate_cycles}. *)\nmodule Delegate : sig\n val check_not_tz4 : Signature.public_key_hash -> unit tzresult\n\n val frozen_deposits_limit :\n context -> public_key_hash -> Tez.t option tzresult Lwt.t\n\n val set_frozen_deposits_limit :\n context -> public_key_hash -> Tez.t option -> context Lwt.t\n\n val fold :\n context ->\n order:[`Sorted | `Undefined] ->\n init:'a ->\n f:(public_key_hash -> 'a -> 'a Lwt.t) ->\n 'a Lwt.t\n\n val list : context -> public_key_hash list Lwt.t\n\n val drain :\n context ->\n delegate:public_key_hash ->\n destination:public_key_hash ->\n (context * bool * Tez.t * Receipt.balance_updates) tzresult Lwt.t\n\n type participation_info = {\n expected_cycle_activity : int;\n minimal_cycle_activity : int;\n missed_slots : int;\n missed_levels : int;\n remaining_allowed_missed_slots : int;\n expected_endorsing_rewards : Tez.t;\n }\n\n val participation_info :\n context -> public_key_hash -> participation_info tzresult Lwt.t\n\n val cycle_end :\n context ->\n Cycle.t ->\n (context * Receipt.balance_updates * public_key_hash list) tzresult Lwt.t\n\n val already_slashed_for_double_endorsing :\n context -> public_key_hash -> Level.t -> bool tzresult Lwt.t\n\n val already_slashed_for_double_baking :\n context -> public_key_hash -> Level.t -> bool tzresult Lwt.t\n\n val punish_double_endorsing :\n context ->\n public_key_hash ->\n Level.t ->\n (context * Tez.t * Receipt.balance_updates) tzresult Lwt.t\n\n val punish_double_baking :\n context ->\n public_key_hash ->\n Level.t ->\n (context * Tez.t * Receipt.balance_updates) tzresult Lwt.t\n\n val full_balance : context -> public_key_hash -> Tez.t tzresult Lwt.t\n\n type level_participation = Participated | Didn't_participate\n\n val record_baking_activity_and_pay_rewards_and_fees :\n context ->\n payload_producer:public_key_hash ->\n block_producer:public_key_hash ->\n baking_reward:Tez.t ->\n reward_bonus:Tez.t option ->\n (context * Receipt.balance_updates) tzresult Lwt.t\n\n val record_endorsing_participation :\n context ->\n delegate:public_key_hash ->\n participation:level_participation ->\n endorsing_power:int ->\n context tzresult Lwt.t\n\n type deposits = {initial_amount : Tez.t; current_amount : Tez.t}\n\n val frozen_deposits : context -> public_key_hash -> deposits tzresult Lwt.t\n\n val staking_balance : context -> public_key_hash -> Tez.t tzresult Lwt.t\n\n (** See {!Contract_delegate_storage.delegated_contracts}. *)\n val delegated_contracts : context -> public_key_hash -> Contract.t list Lwt.t\n\n val delegated_balance : context -> public_key_hash -> Tez.t tzresult Lwt.t\n\n val registered : context -> public_key_hash -> bool Lwt.t\n\n val deactivated : context -> public_key_hash -> bool tzresult Lwt.t\n\n (** See {!Delegate_activation_storage.last_cycle_before_deactivation}. *)\n val last_cycle_before_deactivation :\n context -> public_key_hash -> Cycle.t tzresult Lwt.t\n\n module Consensus_key : sig\n val check_not_tz4 : Signature.public_key -> unit tzresult\n\n val active_pubkey :\n context -> public_key_hash -> Consensus_key.pk tzresult Lwt.t\n\n val pending_updates :\n context ->\n public_key_hash ->\n (Cycle.t * public_key_hash) list tzresult Lwt.t\n\n val register_update :\n context -> public_key_hash -> public_key -> context tzresult Lwt.t\n end\n\n (** See {!Stake_storage.prepare_stake_distribution}. *)\n val prepare_stake_distribution : context -> context tzresult Lwt.t\nend\n\n(** This module re-exports definitions from {!Voting_period_repr} and\n {!Voting_period_storage}. *)\nmodule Voting_period : sig\n type kind = Proposal | Exploration | Cooldown | Promotion | Adoption\n\n val kind_encoding : kind Data_encoding.encoding\n\n val pp_kind : Format.formatter -> kind -> unit\n\n (* This type should be abstract *)\n type voting_period = private {\n index : int32;\n kind : kind;\n start_position : int32;\n }\n\n type t = voting_period\n\n include BASIC_DATA with type t := t\n\n val encoding : voting_period Data_encoding.t\n\n val pp : Format.formatter -> voting_period -> unit\n\n val reset : context -> context tzresult Lwt.t\n\n val succ : context -> context tzresult Lwt.t\n\n val get_current : context -> voting_period tzresult Lwt.t\n\n val get_current_kind : context -> kind tzresult Lwt.t\n\n val is_last_block : context -> bool tzresult Lwt.t\n\n type info = {voting_period : t; position : int32; remaining : int32}\n\n val info_encoding : info Data_encoding.t\n\n val pp_info : Format.formatter -> info -> unit\n\n val get_rpc_current_info : context -> info tzresult Lwt.t\n\n val get_rpc_succ_info : context -> info tzresult Lwt.t\n\n module Testnet_dictator : sig\n (** See {!Voting_period_storage.Testnet_dictator.overwrite_current_kind}. *)\n val overwrite_current_kind :\n context -> Chain_id.t -> Voting_period_repr.kind -> context tzresult Lwt.t\n end\nend\n\n(** This module re-exports definitions from {!Vote_repr} and {!Vote_storage}. *)\nmodule Vote : sig\n type proposal = Protocol_hash.t\n\n (** See {!Vote_storage.get_delegate_proposal_count}. *)\n val get_delegate_proposal_count :\n context -> public_key_hash -> int tzresult Lwt.t\n\n (** See {!Vote_storage.set_delegate_proposal_count}. *)\n val set_delegate_proposal_count :\n context -> public_key_hash -> int -> context Lwt.t\n\n (** See {!Vote_storage.has_proposed}. *)\n val has_proposed : context -> public_key_hash -> proposal -> bool Lwt.t\n\n (** See {!Vote_storage.add_proposal}. *)\n val add_proposal : context -> public_key_hash -> proposal -> context Lwt.t\n\n val get_proposals : context -> int64 Protocol_hash.Map.t tzresult Lwt.t\n\n val clear_proposals : context -> context Lwt.t\n\n val listings_encoding : (public_key_hash * int64) list Data_encoding.t\n\n val update_listings : context -> context tzresult Lwt.t\n\n val in_listings : context -> public_key_hash -> bool Lwt.t\n\n val get_listings : context -> (public_key_hash * int64) list Lwt.t\n\n type ballot = Yay | Nay | Pass\n\n val equal_ballot : ballot -> ballot -> bool\n\n val pp_ballot : Format.formatter -> ballot -> unit\n\n type delegate_info = {\n voting_power : Int64.t option;\n current_ballot : ballot option;\n current_proposals : Protocol_hash.t list;\n remaining_proposals : int;\n }\n\n val pp_delegate_info : Format.formatter -> delegate_info -> unit\n\n val delegate_info_encoding : delegate_info Data_encoding.t\n\n val get_delegate_info :\n context -> public_key_hash -> delegate_info tzresult Lwt.t\n\n val get_voting_power_free : context -> public_key_hash -> int64 tzresult Lwt.t\n\n val get_voting_power :\n context -> public_key_hash -> (context * int64) tzresult Lwt.t\n\n val get_total_voting_power_free : context -> int64 tzresult Lwt.t\n\n val get_total_voting_power : context -> (context * int64) tzresult Lwt.t\n\n val ballot_encoding : ballot Data_encoding.t\n\n type ballots = {yay : int64; nay : int64; pass : int64}\n\n (** See {!Vote_storage.ballots_zero}. *)\n val ballots_zero : ballots\n\n (** See {!Vote_storage.ballots_encoding} *)\n val ballots_encoding : ballots Data_encoding.t\n\n (** See {!Vote_storage.equal_ballots}. *)\n val equal_ballots : ballots -> ballots -> bool\n\n (** See {!Vote_storage.pp_ballots}. *)\n val pp_ballots : Format.formatter -> ballots -> unit\n\n val has_recorded_ballot : context -> public_key_hash -> bool Lwt.t\n\n val record_ballot :\n context -> public_key_hash -> ballot -> context tzresult Lwt.t\n\n val get_ballots : context -> ballots tzresult Lwt.t\n\n val get_ballot_list : context -> (public_key_hash * ballot) list Lwt.t\n\n val clear_ballots : context -> context Lwt.t\n\n val get_current_quorum : context -> int32 tzresult Lwt.t\n\n val get_participation_ema : context -> int32 tzresult Lwt.t\n\n val set_participation_ema : context -> int32 -> context tzresult Lwt.t\n\n (** See {!Vote_storage.current_proposal_exists}. *)\n val current_proposal_exists : context -> bool Lwt.t\n\n (** See {!Vote_storage.get_current_proposal}. *)\n val get_current_proposal : context -> proposal tzresult Lwt.t\n\n (** See {!Vote_storage.find_current_proposal}. *)\n val find_current_proposal : context -> proposal option tzresult Lwt.t\n\n (** See {!Vote_storage.init_current_proposal}. *)\n val init_current_proposal : context -> proposal -> context tzresult Lwt.t\n\n (** See {!Vote_storage.clear_current_proposal}. *)\n val clear_current_proposal : context -> context Lwt.t\nend\n\n(** This module exposes definitions for the data-availability layer. *)\nmodule Dal : sig\n type parameters = Dal.parameters = {\n redundancy_factor : int;\n page_size : int;\n slot_size : int;\n number_of_shards : int;\n }\n\n (** This module re-exports definitions from {!Dal_slot_repr.Index}. *)\n module Slot_index : sig\n type t\n\n val pp : Format.formatter -> t -> unit\n\n val zero : t\n\n val encoding : t Data_encoding.t\n\n val of_int : int -> t option\n\n val to_int : t -> int\n\n val compare : t -> t -> int\n\n val equal : t -> t -> bool\n end\n\n (** This module re-exports definitions from {!Dal_attestation_repr} and\n {!Raw_context.Dal}. *)\n module Attestation : sig\n type t\n\n type operation = {\n attestor : public_key_hash;\n attestation : t;\n level : Raw_level.t;\n }\n\n type shard_index = int\n\n module Shard_map : Map.S with type key = shard_index\n\n val encoding : t Data_encoding.t\n\n val empty : t\n\n val is_attested : t -> Slot_index.t -> bool\n\n val occupied_size_in_bits : t -> int\n\n val expected_size_in_bits : max_index:Slot_index.t -> int\n\n val shards_of_attestor :\n context -> attestor:public_key_hash -> shard_index list option\n\n val record_available_shards : context -> t -> int list -> context\n\n type committee = {\n pkh_to_shards : (shard_index * int) Signature.Public_key_hash.Map.t;\n shard_to_pkh : Signature.Public_key_hash.t Shard_map.t;\n }\n\n val compute_committee :\n context ->\n (Slot.t -> (context * Signature.Public_key_hash.t) tzresult Lwt.t) ->\n committee tzresult Lwt.t\n\n val init_committee : context -> committee -> context\n end\n\n type slot_id = {published_level : Raw_level.t; index : Slot_index.t}\n\n module Page : sig\n type content = bytes\n\n val pages_per_slot : parameters -> int\n\n module Index : sig\n type t = int\n\n val encoding : int Data_encoding.t\n\n val pp : Format.formatter -> int -> unit\n\n val compare : int -> int -> int\n\n val equal : int -> int -> bool\n end\n\n type t = {slot_id : slot_id; page_index : Index.t}\n\n val content_encoding : content Data_encoding.t\n\n type proof = Dal.page_proof\n\n val encoding : t Data_encoding.t\n\n val pp : Format.formatter -> t -> unit\n\n val equal : t -> t -> bool\n end\n\n (** This module re-exports definitions from {!Dal_slot_repr},\n {!Dal_slot_storage} and {!Raw_context.Dal}. *)\n module Slot : sig\n (** This module re-exports definitions from {!Dal_slot_repr.Header}. *)\n module Commitment : sig\n type t = Dal.commitment\n\n val encoding : t Data_encoding.t\n\n val zero : t\n end\n\n module Commitment_proof : sig\n type t = Dal.commitment_proof\n\n val encoding : t Data_encoding.t\n\n val zero : t\n end\n\n module Header : sig\n type id = slot_id = {published_level : Raw_level.t; index : Slot_index.t}\n\n type t = {id : id; commitment : Commitment.t}\n\n type operation = {header : t; proof : Commitment_proof.t}\n\n val id_encoding : id Data_encoding.t\n\n val encoding : t Data_encoding.t\n\n val pp_id : Format.formatter -> id -> unit\n\n val pp : Format.formatter -> t -> unit\n\n val equal : t -> t -> bool\n\n val verify_commitment : parameters -> operation -> bool tzresult\n end\n\n val register_slot_header : context -> Header.t -> (context * bool) tzresult\n\n val find_slot_headers :\n context -> Raw_level.t -> Header.t list option tzresult Lwt.t\n\n val finalize_current_slot_headers : context -> context Lwt.t\n\n val finalize_pending_slot_headers :\n context -> (context * Attestation.t) tzresult Lwt.t\n end\n\n module Slots_history : sig\n type t\n\n module Pointer_hash : S.HASH\n\n type hash = Pointer_hash.t\n\n (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/3766\n Do we need to export this? *)\n val genesis : t\n\n val equal : t -> t -> bool\n\n val encoding : t Data_encoding.t\n\n val hash : t -> hash\n\n module History_cache :\n Bounded_history_repr.S with type key = hash and type value = t\n\n val add_confirmed_slot_headers_no_cache :\n t -> Slot.Header.t list -> t tzresult\n\n val add_confirmed_slot_headers :\n t ->\n History_cache.t ->\n Slot.Header.t list ->\n (t * History_cache.t) tzresult\n\n type proof\n end\n\n module Slots_storage : sig\n val get_slot_headers_history : t -> Slots_history.t tzresult Lwt.t\n end\nend\n\n(** This module re-exports definitions from {!Dal_errors_repr}. *)\nmodule Dal_errors : sig\n (* DAL/FIXME: https://gitlab.com/tezos/tezos/-/issues/3168\n do not expose these errors and return them in functions\n from Dal_slot_repr or Dal_attestation_repr. *)\n type error +=\n | Dal_feature_disabled\n | Dal_slot_index_above_hard_limit\n | Dal_attestation_unexpected_size of {expected : int; got : int}\n | Dal_publish_slot_header_future_level of {\n provided : Raw_level.t;\n expected : Raw_level.t;\n }\n | Dal_publish_slot_header_past_level of {\n provided : Raw_level.t;\n expected : Raw_level.t;\n }\n | Dal_publish_slot_header_invalid_index of {\n given : Dal.Slot_index.t;\n maximum : Dal.Slot_index.t;\n }\n | Dal_publish_slot_header_candidate_with_low_fees of {proposed_fees : Tez.t}\n | Dal_attestation_size_limit_exceeded of {maximum_size : int; got : int}\n | Dal_publish_slot_header_duplicate of {slot_header : Dal.Slot.Header.t}\n | Dal_publish_slot_header_invalid_proof of {\n slot_header : Dal.Slot.Header.operation;\n }\n | Dal_data_availibility_attestor_not_in_committee of {\n attestor : Signature.Public_key_hash.t;\n level : Level.t;\n }\n | Dal_operation_for_old_level of {\n current : Raw_level.t;\n given : Raw_level.t;\n }\n | Dal_operation_for_future_level of {\n current : Raw_level.t;\n given : Raw_level.t;\n }\nend\n\n(** This module re-exports definitions from {!Sc_rollup_storage} and\n {!Sc_rollup_repr}. *)\nmodule Sc_rollup : sig\n (** See {!Sc_rollup_tick_repr}. *)\n module Tick : sig\n type t\n\n val initial : t\n\n val next : t -> t\n\n val jump : t -> Z.t -> t\n\n val distance : t -> t -> Z.t\n\n val of_int : int -> t option\n\n val to_int : t -> int option\n\n val of_z : Z.t -> t\n\n val to_z : t -> Z.t\n\n val encoding : t Data_encoding.t\n\n val pp : Format.formatter -> t -> unit\n\n include Compare.S with type t := t\n\n module Map : Map.S with type key = t\n end\n\n module Address = Sc_rollup_repr.Address\n\n type t = Sc_rollup_repr.t\n\n type rollup := t\n\n val in_memory_size : t -> Cache_memory_helpers.sint\n\n val must_exist : context -> t -> context tzresult Lwt.t\n\n module Staker : sig\n include S.SIGNATURE_PUBLIC_KEY_HASH with type t = public_key_hash\n\n module Index : sig\n type t = private Z.t\n\n val encoding : t Data_encoding.t\n end\n end\n\n module State_hash : sig\n include S.HASH\n\n val context_hash_to_state_hash : Context_hash.t -> t\n\n type unreachable = |\n\n val hash_bytes : unreachable -> t\n\n val hash_string : unreachable -> t\n end\n\n (** See {!Sc_rollup_metadata_repr}. *)\n module Metadata : sig\n type t = {address : rollup; origination_level : Raw_level.t}\n\n val pp : Format.formatter -> t -> unit\n\n val equal : t -> t -> bool\n\n val encoding : t Data_encoding.t\n end\n\n (** See {!Sc_rollup_inbox_message_repr}. *)\n module Inbox_message : sig\n type internal_inbox_message =\n | Transfer of {\n payload : Script.expr;\n sender : Contract_hash.t;\n source : public_key_hash;\n destination : t;\n }\n | Start_of_level\n | End_of_level\n | Info_per_level of {\n predecessor_timestamp : Time.t;\n predecessor : Block_hash.t;\n }\n\n type t = Internal of internal_inbox_message | External of string\n\n type serialized\n\n val encoding : t Data_encoding.t\n\n val unsafe_of_string : string -> serialized\n\n val unsafe_to_string : serialized -> string\n\n val serialize : t -> serialized tzresult\n\n val deserialize : serialized -> t tzresult\n\n module Hash : S.HASH\n\n val hash_serialized_message : serialized -> Hash.t\n end\n\n module Inbox_merkelized_payload_hashes : sig\n module Hash : S.HASH\n\n type t\n\n val encoding : t Data_encoding.t\n\n val equal : t -> t -> bool\n\n val hash : t -> Hash.t\n\n val get_payload_hash : t -> Inbox_message.Hash.t\n\n val get_index : t -> Z.t\n\n type merkelized_and_payload = {\n merkelized : t;\n payload : Inbox_message.serialized;\n }\n\n module History : sig\n include\n Bounded_history_repr.S\n with type key = Hash.t\n and type value = merkelized_and_payload\n\n val no_history : t\n end\n\n val genesis :\n History.t -> Inbox_message.serialized -> (History.t * t) tzresult\n\n val add_payload :\n History.t -> t -> Inbox_message.serialized -> (History.t * t) tzresult\n\n type proof = private t list\n\n val proof_encoding : proof Data_encoding.t\n\n val produce_proof :\n History.t -> index:Z.t -> t -> (merkelized_and_payload * proof) option\n\n val verify_proof : proof -> (t * t) tzresult\n\n module Internal_for_tests : sig\n val find_predecessor_payload : History.t -> index:Z.t -> t -> t option\n\n val make_proof : t list -> proof\n end\n end\n\n type inbox_message = {\n inbox_level : Raw_level.t;\n message_counter : Z.t;\n payload : Inbox_message.serialized;\n }\n\n type reveal_data =\n | Raw_data of string\n | Metadata of Metadata.t\n | Dal_page of Dal.Page.content option\n\n type input = Inbox_message of inbox_message | Reveal of reveal_data\n\n val pp_inbox_message : Format.formatter -> inbox_message -> unit\n\n val inbox_message_equal : inbox_message -> inbox_message -> bool\n\n val pp_reveal_data : Format.formatter -> reveal_data -> unit\n\n val pp_input : Format.formatter -> input -> unit\n\n val input_equal : input -> input -> bool\n\n val input_encoding : input Data_encoding.t\n\n module Input_hash : S.HASH\n\n type reveal =\n | Reveal_raw_data of Sc_rollup_reveal_hash.t\n | Reveal_metadata\n | Request_dal_page of Dal.Page.t\n\n type input_request =\n | No_input_required\n | Initial\n | First_after of Raw_level.t * Z.t\n | Needs_reveal of reveal\n\n val input_request_encoding : input_request Data_encoding.t\n\n val input_request_equal : input_request -> input_request -> bool\n\n val pp_input_request : Format.formatter -> input_request -> unit\n\n module Inbox : sig\n module Skip_list : Skip_list_repr.S\n\n module Hash : S.HASH\n\n type level_proof = {\n hash : Inbox_merkelized_payload_hashes.Hash.t;\n level : Raw_level.t;\n }\n\n type history_proof = (level_proof, Hash.t) Skip_list.cell\n\n type t = {level : Raw_level.t; old_levels_messages : history_proof}\n\n val pp : Format.formatter -> t -> unit\n\n val encoding : t Data_encoding.t\n\n val equal : t -> t -> bool\n\n val inbox_level : t -> Raw_level.t\n\n val old_levels_messages : t -> history_proof\n\n val equal_history_proof : history_proof -> history_proof -> bool\n\n val pp_history_proof : Format.formatter -> history_proof -> unit\n\n val hash : t -> Hash.t\n\n val current_witness : t -> Inbox_merkelized_payload_hashes.Hash.t\n\n module History :\n Bounded_history_repr.S\n with type key = Hash.t\n and type value = history_proof\n\n type serialized_proof\n\n val serialized_proof_encoding : serialized_proof Data_encoding.t\n\n val add_all_messages :\n predecessor_timestamp:Time.t ->\n predecessor:Block_hash.t ->\n History.t ->\n t ->\n Inbox_message.t list ->\n (Inbox_merkelized_payload_hashes.History.t\n * History.t\n * t\n * Inbox_merkelized_payload_hashes.t\n * Inbox_message.t list)\n tzresult\n\n val add_messages_no_history :\n Inbox_message.serialized list ->\n Inbox_merkelized_payload_hashes.t ->\n Inbox_merkelized_payload_hashes.t tzresult\n\n val take_snapshot : t -> history_proof\n\n type inclusion_proof\n\n val inclusion_proof_encoding : inclusion_proof Data_encoding.t\n\n val pp_inclusion_proof : Format.formatter -> inclusion_proof -> unit\n\n val number_of_proof_steps : inclusion_proof -> int\n\n val verify_inclusion_proof :\n inclusion_proof -> history_proof -> history_proof tzresult\n\n type proof\n\n val pp_proof : Format.formatter -> proof -> unit\n\n val to_serialized_proof : proof -> serialized_proof\n\n val of_serialized_proof : serialized_proof -> proof option\n\n val verify_proof :\n Raw_level.t * Z.t ->\n history_proof ->\n proof ->\n inbox_message option tzresult\n\n val produce_proof :\n get_payloads_history:\n (Inbox_merkelized_payload_hashes.Hash.t ->\n Inbox_merkelized_payload_hashes.History.t Lwt.t) ->\n get_history:(Hash.t -> history_proof option Lwt.t) ->\n history_proof ->\n Raw_level.t * Z.t ->\n (proof * inbox_message option) tzresult Lwt.t\n\n val finalize_inbox_level_no_history :\n t -> Inbox_merkelized_payload_hashes.t -> t tzresult\n\n val init_witness_no_history : Inbox_merkelized_payload_hashes.t\n\n val add_info_per_level_no_history :\n predecessor_timestamp:Time.t ->\n predecessor:Block_hash.t ->\n Inbox_merkelized_payload_hashes.t ->\n Inbox_merkelized_payload_hashes.t tzresult\n\n val genesis :\n predecessor_timestamp:Time.t ->\n predecessor:Block_hash.t ->\n Raw_level.t ->\n t tzresult\n\n module Internal_for_tests : sig\n val produce_inclusion_proof :\n (Hash.t -> history_proof option Lwt.t) ->\n history_proof ->\n Raw_level.t ->\n (inclusion_proof * history_proof) tzresult Lwt.t\n\n val serialized_proof_of_string : string -> serialized_proof\n\n val add_start_of_level : context -> context tzresult Lwt.t\n\n val add_end_of_level : context -> context tzresult Lwt.t\n\n val add_info_per_level :\n context -> Time.t -> Block_hash.t -> context tzresult Lwt.t\n end\n\n val add_external_messages : context -> string list -> context tzresult Lwt.t\n\n val add_deposit :\n context ->\n payload:Script.expr ->\n sender:Contract_hash.t ->\n source:public_key_hash ->\n destination:rollup ->\n context tzresult Lwt.t\n\n val finalize_inbox_level : context -> context Lwt.t\n\n val add_info_per_level :\n predecessor:Block_hash.t -> context -> context Lwt.t\n\n val get_inbox : context -> (t * context) tzresult Lwt.t\n end\n\n module Outbox : sig\n (** See {!Sc_rollup_outbox_message_repr}. *)\n module Message : sig\n type transaction = {\n unparsed_parameters : Script.expr;\n destination : Contract_hash.t;\n entrypoint : Entrypoint.t;\n }\n\n type t = Atomic_transaction_batch of {transactions : transaction list}\n\n type serialized\n\n val unsafe_of_string : string -> serialized\n\n val unsafe_to_string : serialized -> string\n\n val deserialize : serialized -> t tzresult\n\n val serialize : t -> serialized tzresult\n end\n\n val record_applied_message :\n context ->\n t ->\n Raw_level.t ->\n message_index:int ->\n (Z.t * context) tzresult Lwt.t\n end\n\n type output = {\n outbox_level : Raw_level.t;\n message_index : Z.t;\n message : Outbox.Message.t;\n }\n\n val output_encoding : output Data_encoding.t\n\n module Dissection_chunk : sig\n type t = {state_hash : State_hash.t option; tick : Tick.t}\n\n val equal : t -> t -> bool\n\n val pp : Format.formatter -> t -> unit\n\n type error +=\n | Dissection_number_of_sections_mismatch of {expected : Z.t; given : Z.t}\n | Dissection_invalid_number_of_sections of Z.t\n | Dissection_start_hash_mismatch of {\n expected : State_hash.t option;\n given : State_hash.t option;\n }\n | Dissection_stop_hash_mismatch of State_hash.t option\n | Dissection_edge_ticks_mismatch of {\n dissection_start_tick : Tick.t;\n dissection_stop_tick : Tick.t;\n chunk_start_tick : Tick.t;\n chunk_stop_tick : Tick.t;\n }\n | Dissection_ticks_not_increasing\n | Dissection_invalid_distribution of Z.t\n | Dissection_invalid_successive_states_shape\n end\n\n module PVM : sig\n type boot_sector = string\n\n module type S = sig\n val parse_boot_sector : string -> boot_sector option\n\n val pp_boot_sector : Format.formatter -> boot_sector -> unit\n\n type state\n\n val pp : state -> (Format.formatter -> unit -> unit) Lwt.t\n\n type context\n\n type hash = State_hash.t\n\n type proof\n\n val proof_encoding : proof Data_encoding.t\n\n val proof_start_state : proof -> hash\n\n val proof_stop_state : proof -> hash\n\n val state_hash : state -> hash Lwt.t\n\n val initial_state : empty:state -> state Lwt.t\n\n val install_boot_sector : state -> string -> state Lwt.t\n\n val is_input_state : state -> input_request Lwt.t\n\n val set_input : input -> state -> state Lwt.t\n\n val eval : state -> state Lwt.t\n\n val verify_proof : input option -> proof -> input_request tzresult Lwt.t\n\n val produce_proof :\n context -> input option -> state -> proof tzresult Lwt.t\n\n val verify_origination_proof : proof -> string -> bool Lwt.t\n\n val produce_origination_proof : context -> string -> proof tzresult Lwt.t\n\n type output_proof\n\n val output_proof_encoding : output_proof Data_encoding.t\n\n val output_of_output_proof : output_proof -> output\n\n val state_of_output_proof : output_proof -> State_hash.t\n\n val verify_output_proof : output_proof -> bool Lwt.t\n\n val produce_output_proof :\n context -> state -> output -> (output_proof, error) result Lwt.t\n\n val check_dissection :\n default_number_of_sections:int ->\n start_chunk:Dissection_chunk.t ->\n stop_chunk:Dissection_chunk.t ->\n Dissection_chunk.t list ->\n unit tzresult\n\n val get_current_level : state -> Raw_level.t option Lwt.t\n\n module Internal_for_tests : sig\n val insert_failure : state -> state Lwt.t\n end\n end\n\n type ('state, 'proof, 'output) implementation =\n (module S\n with type state = 'state\n and type proof = 'proof\n and type output_proof = 'output)\n\n type t = Packed : ('state, 'proof, 'output) implementation -> t\n [@@unboxed]\n end\n\n module Kind : sig\n type t = Example_arith | Wasm_2_0_0\n\n val encoding : t Data_encoding.t\n\n val pp : Format.formatter -> t -> unit\n\n val pvm_of : t -> PVM.t\n\n val all : t list\n\n val of_string : string -> t option\n\n val to_string : t -> string\n\n val equal : t -> t -> bool\n end\n\n module ArithPVM : sig\n module type P = sig\n module Tree :\n Context.TREE with type key = string list and type value = bytes\n\n type tree = Tree.tree\n\n val hash_tree : tree -> State_hash.t\n\n type proof\n\n val proof_encoding : proof Data_encoding.t\n\n val proof_before : proof -> State_hash.t\n\n val proof_after : proof -> State_hash.t\n\n val verify_proof :\n proof -> (tree -> (tree * 'a) Lwt.t) -> (tree * 'a) option Lwt.t\n\n val produce_proof :\n Tree.t ->\n tree ->\n (tree -> (tree * 'a) Lwt.t) ->\n (proof * 'a) option Lwt.t\n end\n\n module Make (C : P) : sig\n include\n PVM.S\n with type context = C.Tree.t\n and type state = C.tree\n and type proof = C.proof\n\n val get_tick : state -> Tick.t Lwt.t\n\n type status =\n | Halted\n | Waiting_for_input_message\n | Waiting_for_reveal\n | Waiting_for_metadata\n | Parsing\n | Evaluating\n\n val get_status : state -> status Lwt.t\n\n val get_outbox : Raw_level.t -> state -> output list Lwt.t\n end\n\n val reference_initial_state_hash : State_hash.t\n\n module Protocol_implementation :\n PVM.S\n with type context = Context.t\n and type state = Context.tree\n and type proof = Context.Proof.tree Context.Proof.t\n end\n\n module Wasm_2_0_0PVM : sig\n val ticks_per_snapshot : Z.t\n\n val outbox_validity_period : int32\n\n val outbox_message_limit : Z.t\n\n val well_known_reveal_preimage : string\n\n val well_known_reveal_hash : Sc_rollup_reveal_hash.t\n\n module type P = sig\n module Tree :\n Context.TREE with type key = string list and type value = bytes\n\n type tree = Tree.tree\n\n type proof\n\n val proof_encoding : proof Data_encoding.t\n\n val proof_before : proof -> State_hash.t\n\n val proof_after : proof -> State_hash.t\n\n val verify_proof :\n proof -> (tree -> (tree * 'a) Lwt.t) -> (tree * 'a) option Lwt.t\n\n val produce_proof :\n Tree.t ->\n tree ->\n (tree -> (tree * 'a) Lwt.t) ->\n (proof * 'a) option Lwt.t\n end\n\n module type Make_wasm = module type of Wasm_2_0_0.Make\n\n module Make (Wasm_backend : Make_wasm) (C : P) : sig\n include\n PVM.S\n with type context = C.Tree.t\n and type state = C.tree\n and type proof = C.proof\n\n val get_tick : state -> Tick.t Lwt.t\n\n type status =\n | Computing\n | Waiting_for_input_message\n | Waiting_for_reveal of reveal\n\n val get_status : state -> status Lwt.t\n\n val get_outbox : Raw_level.t -> state -> output list Lwt.t\n\n val produce_proof :\n context -> input option -> state -> proof tzresult Lwt.t\n end\n\n module Protocol_implementation :\n PVM.S\n with type context = Context.t\n and type state = Context.tree\n and type proof = Context.Proof.tree Context.Proof.t\n\n val reference_initial_state_hash : State_hash.t\n end\n\n module Number_of_ticks : sig\n include Bounded.S with type ocaml_type := int64\n\n val zero : t\n end\n\n module Commitment : sig\n module Hash : S.HASH\n\n type t = {\n compressed_state : State_hash.t;\n inbox_level : Raw_level.t;\n predecessor : Hash.t;\n number_of_ticks : Number_of_ticks.t;\n }\n\n val encoding : t Data_encoding.t\n\n val pp : Format.formatter -> t -> unit\n\n val hash_uncarbonated : t -> Hash.t\n\n val hash : context -> t -> (context * Hash.t) tzresult\n\n val genesis_commitment :\n origination_level:Raw_level.t -> genesis_state_hash:State_hash.t -> t\n\n type genesis_info = {level : Raw_level.t; commitment_hash : Hash.t}\n\n val genesis_info_encoding : genesis_info Data_encoding.t\n\n val get_commitment :\n context -> rollup -> Hash.t -> (t * context) tzresult Lwt.t\n\n val last_cemented_commitment_hash_with_level :\n context -> rollup -> (Hash.t * Raw_level.t * context) tzresult Lwt.t\n\n val check_if_commitments_are_related :\n context ->\n rollup ->\n descendant:Hash.t ->\n ancestor:Hash.t ->\n (bool * context) tzresult Lwt.t\n end\n\n val originate :\n context ->\n kind:Kind.t ->\n parameters_ty:Script.lazy_expr ->\n genesis_commitment:Commitment.t ->\n (t * Z.t * Commitment.Hash.t * context) tzresult Lwt.t\n\n val parameters_type :\n context -> t -> (Script.lazy_expr option * context) tzresult Lwt.t\n\n val kind : context -> t -> (context * Kind.t) tzresult Lwt.t\n\n module Errors : sig\n type error += Sc_rollup_does_not_exist of t\n end\n\n module Proof : sig\n type reveal_proof =\n | Raw_data_proof of string\n | Metadata_proof\n | Dal_page_proof of {\n page_id : Dal.Page.t;\n proof : Dal.Slots_history.proof;\n }\n\n type input_proof =\n | Inbox_proof of {\n level : Raw_level.t;\n message_counter : Z.t;\n proof : Inbox.serialized_proof;\n }\n | Reveal_proof of reveal_proof\n | First_inbox_message\n\n type 'proof t = {pvm_step : 'proof; input_proof : input_proof option}\n\n type serialized = private string\n\n val serialize_pvm_step :\n pvm:('state, 'proof, 'output) PVM.implementation ->\n 'proof ->\n serialized tzresult\n\n val unserialize_pvm_step :\n pvm:('state, 'proof, 'output) PVM.implementation ->\n serialized ->\n 'proof tzresult\n\n val serialized_encoding : serialized Data_encoding.t\n\n val encoding : serialized t Data_encoding.t\n\n module type PVM_with_context_and_state = sig\n include PVM.S\n\n val context : context\n\n val state : state\n\n val proof_encoding : proof Data_encoding.t\n\n val reveal : Sc_rollup_reveal_hash.t -> string option Lwt.t\n\n module Inbox_with_history : sig\n val inbox : Inbox.history_proof\n\n val get_history : Inbox.Hash.t -> Inbox.history_proof option Lwt.t\n\n val get_payloads_history :\n Inbox_merkelized_payload_hashes.Hash.t ->\n Inbox_merkelized_payload_hashes.History.t Lwt.t\n end\n\n module Dal_with_history : sig\n val confirmed_slots_history : Dal.Slots_history.t\n\n val get_history :\n Dal.Slots_history.hash -> Dal.Slots_history.t option Lwt.t\n\n val page_info : (Dal.Page.content * Dal.Page.proof) option\n\n val dal_parameters : Dal.parameters\n\n val dal_attestation_lag : int\n end\n end\n\n type error += Sc_rollup_proof_check of string\n\n val valid :\n pvm:('state, 'proof, 'output) PVM.implementation ->\n metadata:Metadata.t ->\n Inbox.history_proof ->\n Raw_level.t ->\n Dal.Slots_history.t ->\n Dal.parameters ->\n dal_attestation_lag:int ->\n 'proof t ->\n (input option * input_request) tzresult Lwt.t\n\n val produce :\n metadata:Metadata.t ->\n (module PVM_with_context_and_state) ->\n Raw_level.t ->\n serialized t tzresult Lwt.t\n end\n\n module Game : sig\n type player = Alice | Bob\n\n val player_equal : player -> player -> bool\n\n val player_encoding : player Data_encoding.t\n\n type dissection_chunk = Dissection_chunk.t\n\n type game_state =\n | Dissecting of {\n dissection : dissection_chunk list;\n default_number_of_sections : int;\n }\n | Final_move of {\n agreed_start_chunk : dissection_chunk;\n refuted_stop_chunk : dissection_chunk;\n }\n\n val game_state_encoding : game_state Data_encoding.t\n\n val game_state_equal : game_state -> game_state -> bool\n\n type t = {\n turn : player;\n inbox_snapshot : Inbox.history_proof;\n dal_snapshot : Dal.Slots_history.t;\n start_level : Raw_level.t;\n inbox_level : Raw_level.t;\n game_state : game_state;\n }\n\n val pp_dissection : Format.formatter -> dissection_chunk list -> unit\n\n val pp : Format.formatter -> t -> unit\n\n module Index : sig\n type t = private {alice : Staker.t; bob : Staker.t}\n\n val encoding : t Data_encoding.t\n\n val make : Staker.t -> Staker.t -> t\n end\n\n val encoding : t Data_encoding.t\n\n val opponent : player -> player\n\n type step =\n | Dissection of dissection_chunk list\n | Proof of Proof.serialized Proof.t\n\n type refutation =\n | Start of {\n player_commitment_hash : Commitment.Hash.t;\n opponent_commitment_hash : Commitment.Hash.t;\n }\n | Move of {choice : Tick.t; step : step}\n\n val refutation_encoding : refutation Data_encoding.t\n\n val pp_refutation : Format.formatter -> refutation -> unit\n\n type reason = Conflict_resolved | Timeout\n\n val pp_reason : Format.formatter -> reason -> unit\n\n val reason_encoding : reason Data_encoding.t\n\n type game_result = Loser of {reason : reason; loser : Staker.t} | Draw\n\n val pp_game_result : Format.formatter -> game_result -> unit\n\n val game_result_encoding : game_result Data_encoding.t\n\n type status = Ongoing | Ended of game_result\n\n val pp_status : Format.formatter -> status -> unit\n\n val status_encoding : status Data_encoding.t\n\n val loser_of_results : alice_result:bool -> bob_result:bool -> player option\n\n val initial :\n Inbox.history_proof ->\n Dal.Slots_history.t ->\n start_level:Raw_level.t ->\n parent_commitment:Commitment.t ->\n defender_commitment:Commitment.t ->\n refuter:Staker.t ->\n defender:Staker.t ->\n default_number_of_sections:int ->\n t\n\n val play :\n Kind.t ->\n Dal.parameters ->\n dal_attestation_lag:int ->\n stakers:Index.t ->\n Metadata.t ->\n t ->\n step:step ->\n choice:Tick.t ->\n (game_result, t) Either.t tzresult Lwt.t\n\n type timeout = {alice : int; bob : int; last_turn_level : Raw_level.t}\n\n val timeout_encoding : timeout Data_encoding.t\n\n type error +=\n | Dissection_choice_not_found of Tick.t\n | Proof_unexpected_section_size of Z.t\n | Proof_start_state_hash_mismatch of {\n start_state_hash : State_hash.t option;\n start_proof : State_hash.t;\n }\n | Proof_stop_state_hash_failed_to_refute of {\n stop_state_hash : State_hash.t option;\n stop_proof : State_hash.t option;\n }\n | Proof_stop_state_hash_failed_to_validate of {\n stop_state_hash : State_hash.t option;\n stop_proof : State_hash.t option;\n }\n | Dissecting_during_final_move\n\n module Internal_for_tests : sig\n val check_dissection :\n default_number_of_sections:int ->\n start_chunk:dissection_chunk ->\n stop_chunk:dissection_chunk ->\n dissection_chunk list ->\n unit tzresult\n end\n end\n\n module Stake_storage : sig\n val find_staker :\n context ->\n t ->\n Staker.t ->\n (context * Commitment.Hash.t option) tzresult Lwt.t\n\n val publish_commitment :\n context ->\n t ->\n Staker.t ->\n Commitment.t ->\n (Commitment.Hash.t * Raw_level.t * context * Receipt.balance_updates)\n tzresult\n Lwt.t\n\n val cement_commitment :\n context ->\n t ->\n Commitment.Hash.t ->\n (context * Commitment.t) tzresult Lwt.t\n\n val withdraw_stake :\n context ->\n t ->\n Staker.t ->\n (context * Receipt.balance_updates) tzresult Lwt.t\n\n val commitments_uncarbonated :\n context ->\n rollup:t ->\n inbox_level:Raw_level.t ->\n Commitment.Hash.t list option tzresult Lwt.t\n\n val stakers_ids_uncarbonated :\n context ->\n rollup:t ->\n commitment:Commitment.Hash.t ->\n Staker.Index.t list tzresult Lwt.t\n\n val staker_id_uncarbonated :\n context ->\n rollup:t ->\n pkh:public_key_hash ->\n Staker.Index.t tzresult Lwt.t\n\n val stakers_pkhs_uncarbonated :\n context -> rollup:t -> public_key_hash list Lwt.t\n end\n\n module Refutation_storage : sig\n type point = {commitment : Commitment.t; hash : Commitment.Hash.t}\n\n type conflict_point = point * point\n\n type conflict = {\n other : Staker.t;\n their_commitment : Commitment.t;\n our_commitment : Commitment.t;\n parent_commitment : Commitment.Hash.t;\n }\n\n val conflict_encoding : conflict Data_encoding.t\n\n val conflicting_stakers_uncarbonated :\n context -> t -> Staker.t -> conflict list tzresult Lwt.t\n\n val get_ongoing_games_for_staker :\n context ->\n t ->\n Staker.t ->\n ((Game.t * Game.Index.t) list * context) tzresult Lwt.t\n\n val start_game :\n context ->\n t ->\n player:public_key_hash * Commitment.Hash.t ->\n opponent:public_key_hash * Commitment.Hash.t ->\n context tzresult Lwt.t\n\n val game_move :\n context ->\n t ->\n player:Staker.t ->\n opponent:Staker.t ->\n step:Game.step ->\n choice:Tick.t ->\n (Game.game_result option * context) tzresult Lwt.t\n\n val get_timeout :\n context -> t -> Game.Index.t -> (Game.timeout * context) tzresult Lwt.t\n\n val timeout :\n context ->\n t ->\n Game.Index.t ->\n (Game.game_result * context) tzresult Lwt.t\n\n val apply_game_result :\n context ->\n t ->\n Game.Index.t ->\n Game.game_result ->\n (Game.status * context * Receipt.balance_updates) tzresult Lwt.t\n\n module Internal_for_tests : sig\n val get_conflict_point :\n context ->\n t ->\n Staker.t ->\n Staker.t ->\n (conflict_point * context) tzresult Lwt.t\n end\n end\n\n val rpc_arg : t RPC_arg.t\n\n val list_unaccounted : context -> t list tzresult Lwt.t\n\n val genesis_info :\n context -> rollup -> (context * Commitment.genesis_info) tzresult Lwt.t\n\n (** This module discloses definitions that are only useful for tests and\n must not be used otherwise. *)\n module Internal_for_tests : sig\n val originated_sc_rollup : Origination_nonce.Internal_for_tests.t -> t\n end\nend\n\n(** This module re-exports definitions from {!Destination_repr}. *)\nmodule Destination : sig\n type t =\n | Contract of Contract.t\n | Tx_rollup of Tx_rollup.t\n | Sc_rollup of Sc_rollup.t\n | Zk_rollup of Zk_rollup.t\n\n val encoding : t Data_encoding.t\n\n val pp : Format.formatter -> t -> unit\n\n val compare : t -> t -> int\n\n val equal : t -> t -> bool\n\n val to_b58check : t -> string\n\n val of_b58check : string -> t tzresult\n\n val in_memory_size : t -> Cache_memory_helpers.sint\n\n val must_exist : context -> t -> context tzresult Lwt.t\n\n type error += Invalid_destination_b58check of string\nend\n\n(** See {!Block_payload_repr}. *)\nmodule Block_payload : sig\n (** See {!Block_payload_repr.hash}. *)\n val hash :\n predecessor_hash:Block_hash.t ->\n payload_round:Round.t ->\n Operation_list_hash.elt list ->\n Block_payload_hash.t\nend\n\n(** This module re-exports definitions from {!Block_header_repr}. *)\nmodule Block_header : sig\n type contents = {\n payload_hash : Block_payload_hash.t;\n payload_round : Round.t;\n seed_nonce_hash : Nonce_hash.t option;\n proof_of_work_nonce : bytes;\n liquidity_baking_toggle_vote :\n Liquidity_baking_repr.liquidity_baking_toggle_vote;\n }\n\n type protocol_data = {contents : contents; signature : signature}\n\n type t = {shell : Block_header.shell_header; protocol_data : protocol_data}\n\n type block_header = t\n\n type raw = Block_header.t\n\n type shell_header = Block_header.shell_header\n\n type block_watermark = Block_header of Chain_id.t\n\n val to_watermark : block_watermark -> Signature.watermark\n\n val of_watermark : Signature.watermark -> block_watermark option\n\n module Proof_of_work : sig\n val check_hash : Block_hash.t -> int64 -> bool\n\n val check_header_proof_of_work_stamp :\n shell_header -> contents -> int64 -> bool\n\n val check_proof_of_work_stamp :\n proof_of_work_threshold:int64 -> block_header -> unit tzresult\n end\n\n val raw : block_header -> raw\n\n val hash : block_header -> Block_hash.t\n\n val hash_raw : raw -> Block_hash.t\n\n val encoding : block_header Data_encoding.encoding\n\n val raw_encoding : raw Data_encoding.t\n\n val contents_encoding : contents Data_encoding.t\n\n val unsigned_encoding : (shell_header * contents) Data_encoding.t\n\n val protocol_data_encoding : protocol_data Data_encoding.encoding\n\n val shell_header_encoding : shell_header Data_encoding.encoding\n\n (** The maximum size of block headers in bytes *)\n val max_header_length : int\n\n type error += Invalid_stamp\n\n val check_timestamp :\n Round.round_durations ->\n timestamp:Time.t ->\n round:Round.t ->\n predecessor_timestamp:Time.t ->\n predecessor_round:Round.t ->\n unit tzresult\n\n val check_signature : t -> Chain_id.t -> public_key -> unit tzresult\n\n val begin_validate_block_header :\n block_header:t ->\n chain_id:Chain_id.t ->\n predecessor_timestamp:Time.t ->\n predecessor_round:Round.t ->\n fitness:Fitness.t ->\n timestamp:Time.t ->\n delegate_pk:public_key ->\n round_durations:Round.round_durations ->\n proof_of_work_threshold:int64 ->\n expected_commitment:bool ->\n unit tzresult\n\n type locked_round_evidence = {\n preendorsement_round : Round.t;\n preendorsement_count : int;\n }\n\n type checkable_payload_hash =\n | No_check\n | Expected_payload_hash of Block_payload_hash.t\n\n val finalize_validate_block_header :\n block_header_contents:contents ->\n round:Round.t ->\n fitness:Fitness.t ->\n checkable_payload_hash:checkable_payload_hash ->\n locked_round_evidence:locked_round_evidence option ->\n consensus_threshold:int ->\n unit tzresult\nend\n\n(** This module re-exports definitions from {!Cache_repr}. *)\nmodule Cache : sig\n type size = int\n\n type index = int\n\n type cache_nonce\n\n module Admin : sig\n type key\n\n type value\n\n val pp : Format.formatter -> context -> unit\n\n val sync : context -> cache_nonce -> context Lwt.t\n\n val future_cache_expectation :\n ?blocks_before_activation:int32 ->\n context ->\n time_in_blocks:int ->\n context tzresult Lwt.t\n\n val cache_size : context -> cache_index:int -> size option\n\n val cache_size_limit : context -> cache_index:int -> size option\n\n val value_of_key :\n context -> Context.Cache.key -> Context.Cache.value tzresult Lwt.t\n end\n\n type namespace = private string\n\n val create_namespace : string -> namespace\n\n type identifier = string\n\n module type CLIENT = sig\n type cached_value\n\n val cache_index : index\n\n val namespace : namespace\n\n val value_of_identifier :\n context -> identifier -> cached_value tzresult Lwt.t\n end\n\n module type INTERFACE = sig\n type cached_value\n\n val update :\n context -> identifier -> (cached_value * size) option -> context tzresult\n\n val find : context -> identifier -> cached_value option tzresult Lwt.t\n\n val list_identifiers : context -> (string * int) list\n\n val identifier_rank : context -> string -> int option\n\n val size : context -> int\n\n val size_limit : context -> int\n end\n\n val register_exn :\n (module CLIENT with type cached_value = 'a) ->\n (module INTERFACE with type cached_value = 'a)\n\n val cache_nonce_from_block_header :\n Block_header.shell_header -> Block_header.contents -> cache_nonce\nend\n\n(** This module re-exports definitions from {!Lazy_storage_kind}. *)\nmodule Kind : sig\n type preendorsement_consensus_kind = Preendorsement_consensus_kind\n\n type endorsement_consensus_kind = Endorsement_consensus_kind\n\n type 'a consensus =\n | Preendorsement_kind : preendorsement_consensus_kind consensus\n | Endorsement_kind : endorsement_consensus_kind consensus\n\n type preendorsement = preendorsement_consensus_kind consensus\n\n type endorsement = endorsement_consensus_kind consensus\n\n type dal_attestation = Dal_attestation_kind\n\n type seed_nonce_revelation = Seed_nonce_revelation_kind\n\n type vdf_revelation = Vdf_revelation_kind\n\n type 'a double_consensus_operation_evidence =\n | Double_consensus_operation_evidence\n\n type double_endorsement_evidence =\n endorsement_consensus_kind double_consensus_operation_evidence\n\n type double_preendorsement_evidence =\n preendorsement_consensus_kind double_consensus_operation_evidence\n\n type double_baking_evidence = Double_baking_evidence_kind\n\n type activate_account = Activate_account_kind\n\n type proposals = Proposals_kind\n\n type ballot = Ballot_kind\n\n type reveal = Reveal_kind\n\n type transaction = Transaction_kind\n\n type origination = Origination_kind\n\n type delegation = Delegation_kind\n\n type event = Event_kind\n\n type set_deposits_limit = Set_deposits_limit_kind\n\n type increase_paid_storage = Increase_paid_storage_kind\n\n type update_consensus_key = Update_consensus_key_kind\n\n type drain_delegate = Drain_delegate_kind\n\n type failing_noop = Failing_noop_kind\n\n type register_global_constant = Register_global_constant_kind\n\n type tx_rollup_origination = Tx_rollup_origination_kind\n\n type tx_rollup_submit_batch = Tx_rollup_submit_batch_kind\n\n type tx_rollup_commit = Tx_rollup_commit_kind\n\n type tx_rollup_return_bond = Tx_rollup_return_bond_kind\n\n type tx_rollup_finalize_commitment = Tx_rollup_finalize_commitment_kind\n\n type tx_rollup_remove_commitment = Tx_rollup_remove_commitment_kind\n\n type tx_rollup_rejection = Tx_rollup_rejection_kind\n\n type tx_rollup_dispatch_tickets = Tx_rollup_dispatch_tickets_kind\n\n type transfer_ticket = Transfer_ticket_kind\n\n type dal_publish_slot_header = Dal_publish_slot_header_kind\n\n type sc_rollup_originate = Sc_rollup_originate_kind\n\n type sc_rollup_add_messages = Sc_rollup_add_messages_kind\n\n type sc_rollup_cement = Sc_rollup_cement_kind\n\n type sc_rollup_publish = Sc_rollup_publish_kind\n\n type sc_rollup_refute = Sc_rollup_refute_kind\n\n type sc_rollup_timeout = Sc_rollup_timeout_kind\n\n type sc_rollup_execute_outbox_message =\n | Sc_rollup_execute_outbox_message_kind\n\n type sc_rollup_recover_bond = Sc_rollup_recover_bond_kind\n\n type zk_rollup_origination = Zk_rollup_origination_kind\n\n type zk_rollup_publish = Zk_rollup_publish_kind\n\n type zk_rollup_update = Zk_rollup_update_kind\n\n type 'a manager =\n | Reveal_manager_kind : reveal manager\n | Transaction_manager_kind : transaction manager\n | Origination_manager_kind : origination manager\n | Delegation_manager_kind : delegation manager\n | Event_manager_kind : event manager\n | Register_global_constant_manager_kind : register_global_constant manager\n | Set_deposits_limit_manager_kind : set_deposits_limit manager\n | Increase_paid_storage_manager_kind : increase_paid_storage manager\n | Update_consensus_key_manager_kind : update_consensus_key manager\n | Tx_rollup_origination_manager_kind : tx_rollup_origination manager\n | Tx_rollup_submit_batch_manager_kind : tx_rollup_submit_batch manager\n | Tx_rollup_commit_manager_kind : tx_rollup_commit manager\n | Tx_rollup_return_bond_manager_kind : tx_rollup_return_bond manager\n | Tx_rollup_finalize_commitment_manager_kind\n : tx_rollup_finalize_commitment manager\n | Tx_rollup_remove_commitment_manager_kind\n : tx_rollup_remove_commitment manager\n | Tx_rollup_rejection_manager_kind : tx_rollup_rejection manager\n | Tx_rollup_dispatch_tickets_manager_kind\n : tx_rollup_dispatch_tickets manager\n | Transfer_ticket_manager_kind : transfer_ticket manager\n | Dal_publish_slot_header_manager_kind : dal_publish_slot_header manager\n | Sc_rollup_originate_manager_kind : sc_rollup_originate manager\n | Sc_rollup_add_messages_manager_kind : sc_rollup_add_messages manager\n | Sc_rollup_cement_manager_kind : sc_rollup_cement manager\n | Sc_rollup_publish_manager_kind : sc_rollup_publish manager\n | Sc_rollup_refute_manager_kind : sc_rollup_refute manager\n | Sc_rollup_timeout_manager_kind : sc_rollup_timeout manager\n | Sc_rollup_execute_outbox_message_manager_kind\n : sc_rollup_execute_outbox_message manager\n | Sc_rollup_recover_bond_manager_kind : sc_rollup_recover_bond manager\n | Zk_rollup_origination_manager_kind : zk_rollup_origination manager\n | Zk_rollup_publish_manager_kind : zk_rollup_publish manager\n | Zk_rollup_update_manager_kind : zk_rollup_update manager\nend\n\n(** All the definitions below are re-exported from {!Operation_repr}. *)\n\ntype 'a consensus_operation_type =\n | Endorsement : Kind.endorsement consensus_operation_type\n | Preendorsement : Kind.preendorsement consensus_operation_type\n\nval pp_operation_kind :\n Format.formatter -> 'kind consensus_operation_type -> unit\n\ntype consensus_content = {\n slot : Slot.t;\n level : Raw_level.t;\n (* The level is not required to validate an endorsement when it corresponds\n to the current payload, but if we want to filter endorsements, we need\n the level. *)\n round : Round.t;\n block_payload_hash : Block_payload_hash.t;\n}\n\nval consensus_content_encoding : consensus_content Data_encoding.t\n\nval pp_consensus_content : Format.formatter -> consensus_content -> unit\n\ntype 'kind operation = {\n shell : Operation.shell_header;\n protocol_data : 'kind protocol_data;\n}\n\nand 'kind protocol_data = {\n contents : 'kind contents_list;\n signature : signature option;\n}\n\nand _ contents_list =\n | Single : 'kind contents -> 'kind contents_list\n | Cons :\n 'kind Kind.manager contents * 'rest Kind.manager contents_list\n -> ('kind * 'rest) Kind.manager contents_list\n\nand _ contents =\n | Preendorsement : consensus_content -> Kind.preendorsement contents\n | Endorsement : consensus_content -> Kind.endorsement contents\n | Dal_attestation : Dal.Attestation.operation -> Kind.dal_attestation contents\n | Seed_nonce_revelation : {\n level : Raw_level.t;\n nonce : Nonce.t;\n }\n -> Kind.seed_nonce_revelation contents\n | Vdf_revelation : {\n solution : Seed.vdf_solution;\n }\n -> Kind.vdf_revelation contents\n | Double_preendorsement_evidence : {\n op1 : Kind.preendorsement operation;\n op2 : Kind.preendorsement operation;\n }\n -> Kind.double_preendorsement_evidence contents\n | Double_endorsement_evidence : {\n op1 : Kind.endorsement operation;\n op2 : Kind.endorsement operation;\n }\n -> Kind.double_endorsement_evidence contents\n | Double_baking_evidence : {\n bh1 : Block_header.t;\n bh2 : Block_header.t;\n }\n -> Kind.double_baking_evidence contents\n | Activate_account : {\n id : Ed25519.Public_key_hash.t;\n activation_code : Blinded_public_key_hash.activation_code;\n }\n -> Kind.activate_account contents\n | Proposals : {\n source : public_key_hash;\n period : int32;\n proposals : Protocol_hash.t list;\n }\n -> Kind.proposals contents\n | Ballot : {\n source : public_key_hash;\n period : int32;\n proposal : Protocol_hash.t;\n ballot : Vote.ballot;\n }\n -> Kind.ballot contents\n | Drain_delegate : {\n consensus_key : Signature.Public_key_hash.t;\n delegate : Signature.Public_key_hash.t;\n destination : Signature.Public_key_hash.t;\n }\n -> Kind.drain_delegate contents\n | Failing_noop : string -> Kind.failing_noop contents\n | Manager_operation : {\n source : public_key_hash;\n fee : Tez.tez;\n counter : Manager_counter.t;\n operation : 'kind manager_operation;\n gas_limit : Gas.Arith.integral;\n storage_limit : Z.t;\n }\n -> 'kind Kind.manager contents\n\nand _ manager_operation =\n | Reveal : public_key -> Kind.reveal manager_operation\n | Transaction : {\n amount : Tez.tez;\n parameters : Script.lazy_expr;\n entrypoint : Entrypoint.t;\n destination : Contract.t;\n }\n -> Kind.transaction manager_operation\n | Origination : {\n delegate : public_key_hash option;\n script : Script.t;\n credit : Tez.tez;\n }\n -> Kind.origination manager_operation\n | Delegation : public_key_hash option -> Kind.delegation manager_operation\n | Register_global_constant : {\n value : Script.lazy_expr;\n }\n -> Kind.register_global_constant manager_operation\n | Set_deposits_limit :\n Tez.t option\n -> Kind.set_deposits_limit manager_operation\n | Increase_paid_storage : {\n amount_in_bytes : Z.t;\n destination : Contract_hash.t;\n }\n -> Kind.increase_paid_storage manager_operation\n | Update_consensus_key :\n Signature.Public_key.t\n -> Kind.update_consensus_key manager_operation\n | Tx_rollup_origination : Kind.tx_rollup_origination manager_operation\n | Tx_rollup_submit_batch : {\n tx_rollup : Tx_rollup.t;\n content : string;\n burn_limit : Tez.tez option;\n }\n -> Kind.tx_rollup_submit_batch manager_operation\n | Tx_rollup_commit : {\n tx_rollup : Tx_rollup.t;\n commitment : Tx_rollup_commitment.Full.t;\n }\n -> Kind.tx_rollup_commit manager_operation\n | Tx_rollup_return_bond : {\n tx_rollup : Tx_rollup.t;\n }\n -> Kind.tx_rollup_return_bond manager_operation\n | Tx_rollup_finalize_commitment : {\n tx_rollup : Tx_rollup.t;\n }\n -> Kind.tx_rollup_finalize_commitment manager_operation\n | Tx_rollup_remove_commitment : {\n tx_rollup : Tx_rollup.t;\n }\n -> Kind.tx_rollup_remove_commitment manager_operation\n | Tx_rollup_rejection : {\n tx_rollup : Tx_rollup.t;\n level : Tx_rollup_level.t;\n message : Tx_rollup_message.t;\n message_position : int;\n message_path : Tx_rollup_inbox.Merkle.path;\n message_result_hash : Tx_rollup_message_result_hash.t;\n message_result_path : Tx_rollup_commitment.Merkle.path;\n previous_message_result : Tx_rollup_message_result.t;\n previous_message_result_path : Tx_rollup_commitment.Merkle.path;\n proof : Tx_rollup_l2_proof.serialized;\n }\n -> Kind.tx_rollup_rejection manager_operation\n | Tx_rollup_dispatch_tickets : {\n tx_rollup : Tx_rollup.t;\n level : Tx_rollup_level.t;\n context_hash : Context_hash.t;\n message_index : int;\n message_result_path : Tx_rollup_commitment.Merkle.path;\n tickets_info : Tx_rollup_reveal.t list;\n }\n -> Kind.tx_rollup_dispatch_tickets manager_operation\n | Transfer_ticket : {\n contents : Script.lazy_expr;\n ty : Script.lazy_expr;\n ticketer : Contract.t;\n amount : Ticket_amount.t;\n destination : Contract.t;\n entrypoint : Entrypoint.t;\n }\n -> Kind.transfer_ticket manager_operation\n | Dal_publish_slot_header :\n Dal.Slot.Header.operation\n -> Kind.dal_publish_slot_header manager_operation\n | Sc_rollup_originate : {\n kind : Sc_rollup.Kind.t;\n boot_sector : string;\n origination_proof : Sc_rollup.Proof.serialized;\n parameters_ty : Script.lazy_expr;\n }\n -> Kind.sc_rollup_originate manager_operation\n | Sc_rollup_add_messages : {\n messages : string list;\n }\n -> Kind.sc_rollup_add_messages manager_operation\n | Sc_rollup_cement : {\n rollup : Sc_rollup.t;\n commitment : Sc_rollup.Commitment.Hash.t;\n }\n -> Kind.sc_rollup_cement manager_operation\n | Sc_rollup_publish : {\n rollup : Sc_rollup.t;\n commitment : Sc_rollup.Commitment.t;\n }\n -> Kind.sc_rollup_publish manager_operation\n | Sc_rollup_refute : {\n rollup : Sc_rollup.t;\n opponent : Sc_rollup.Staker.t;\n refutation : Sc_rollup.Game.refutation;\n }\n -> Kind.sc_rollup_refute manager_operation\n | Sc_rollup_timeout : {\n rollup : Sc_rollup.t;\n stakers : Sc_rollup.Game.Index.t;\n }\n -> Kind.sc_rollup_timeout manager_operation\n | Sc_rollup_execute_outbox_message : {\n rollup : Sc_rollup.t;\n cemented_commitment : Sc_rollup.Commitment.Hash.t;\n output_proof : string;\n }\n -> Kind.sc_rollup_execute_outbox_message manager_operation\n | Sc_rollup_recover_bond : {\n sc_rollup : Sc_rollup.t;\n staker : Signature.Public_key_hash.t;\n }\n -> Kind.sc_rollup_recover_bond manager_operation\n | Zk_rollup_origination : {\n public_parameters : Plonk.public_parameters;\n circuits_info : [`Public | `Private | `Fee] Zk_rollup.Account.SMap.t;\n init_state : Zk_rollup.State.t;\n nb_ops : int;\n }\n -> Kind.zk_rollup_origination manager_operation\n | Zk_rollup_publish : {\n zk_rollup : Zk_rollup.t;\n ops : (Zk_rollup.Operation.t * Zk_rollup.Ticket.t option) list;\n }\n -> Kind.zk_rollup_publish manager_operation\n | Zk_rollup_update : {\n zk_rollup : Zk_rollup.t;\n update : Zk_rollup.Update.t;\n }\n -> Kind.zk_rollup_update manager_operation\n\ntype packed_manager_operation =\n | Manager : 'kind manager_operation -> packed_manager_operation\n\ntype packed_contents = Contents : 'kind contents -> packed_contents\n\ntype packed_contents_list =\n | Contents_list : 'kind contents_list -> packed_contents_list\n\ntype packed_protocol_data =\n | Operation_data : 'kind protocol_data -> packed_protocol_data\n\ntype packed_operation = {\n shell : Operation.shell_header;\n protocol_data : packed_protocol_data;\n}\n\nval manager_kind : 'kind manager_operation -> 'kind Kind.manager\n\n(** This module re-exports definitions from {!Operation_repr}. *)\nmodule Operation : sig\n type nonrec 'kind contents = 'kind contents\n\n type nonrec packed_contents = packed_contents\n\n val contents_encoding : packed_contents Data_encoding.t\n\n type nonrec 'kind protocol_data = 'kind protocol_data\n\n type nonrec packed_protocol_data = packed_protocol_data\n\n type consensus_watermark =\n | Endorsement of Chain_id.t\n | Preendorsement of Chain_id.t\n | Dal_attestation of Chain_id.t\n\n val to_watermark : consensus_watermark -> Signature.watermark\n\n val of_watermark : Signature.watermark -> consensus_watermark option\n\n val protocol_data_encoding : packed_protocol_data Data_encoding.t\n\n val unsigned_encoding :\n (Operation.shell_header * packed_contents_list) Data_encoding.t\n\n type raw = Operation.t = {shell : Operation.shell_header; proto : bytes}\n\n val raw_encoding : raw Data_encoding.t\n\n val contents_list_encoding : packed_contents_list Data_encoding.t\n\n type 'kind t = 'kind operation = {\n shell : Operation.shell_header;\n protocol_data : 'kind protocol_data;\n }\n\n type nonrec packed = packed_operation\n\n val encoding : packed Data_encoding.t\n\n val raw : _ operation -> raw\n\n val hash : _ operation -> Operation_hash.t\n\n val hash_raw : raw -> Operation_hash.t\n\n val hash_packed : packed_operation -> Operation_hash.t\n\n val acceptable_pass : packed_operation -> int option\n\n val compare_by_passes : packed_operation -> packed_operation -> int\n\n type error += Missing_signature (* `Permanent *)\n\n type error += Invalid_signature (* `Permanent *)\n\n val check_signature : public_key -> Chain_id.t -> _ operation -> unit tzresult\n\n val pack : 'kind operation -> packed_operation\n\n val compare :\n Operation_hash.t * packed_operation ->\n Operation_hash.t * packed_operation ->\n int\n\n type ('a, 'b) eq = Eq : ('a, 'a) eq\n\n val equal : 'a operation -> 'b operation -> ('a, 'b) eq option\n\n module Encoding : sig\n type 'b case =\n | Case : {\n tag : int;\n name : string;\n encoding : 'a Data_encoding.t;\n select : packed_contents -> 'b contents option;\n proj : 'b contents -> 'a;\n inj : 'a -> 'b contents;\n }\n -> 'b case\n\n val preendorsement_case : Kind.preendorsement case\n\n val endorsement_case : Kind.endorsement case\n\n val dal_attestation_case : Kind.dal_attestation case\n\n val seed_nonce_revelation_case : Kind.seed_nonce_revelation case\n\n val vdf_revelation_case : Kind.vdf_revelation case\n\n val double_preendorsement_evidence_case :\n Kind.double_preendorsement_evidence case\n\n val double_endorsement_evidence_case : Kind.double_endorsement_evidence case\n\n val double_baking_evidence_case : Kind.double_baking_evidence case\n\n val activate_account_case : Kind.activate_account case\n\n val proposals_case : Kind.proposals case\n\n val ballot_case : Kind.ballot case\n\n val drain_delegate_case : Kind.drain_delegate case\n\n val failing_noop_case : Kind.failing_noop case\n\n val reveal_case : Kind.reveal Kind.manager case\n\n val transaction_case : Kind.transaction Kind.manager case\n\n val origination_case : Kind.origination Kind.manager case\n\n val delegation_case : Kind.delegation Kind.manager case\n\n val update_consensus_key_case : Kind.update_consensus_key Kind.manager case\n\n val tx_rollup_origination_case :\n Kind.tx_rollup_origination Kind.manager case\n\n val tx_rollup_submit_batch_case :\n Kind.tx_rollup_submit_batch Kind.manager case\n\n val tx_rollup_commit_case : Kind.tx_rollup_commit Kind.manager case\n\n val tx_rollup_return_bond_case :\n Kind.tx_rollup_return_bond Kind.manager case\n\n val tx_rollup_finalize_commitment_case :\n Kind.tx_rollup_finalize_commitment Kind.manager case\n\n val tx_rollup_remove_commitment_case :\n Kind.tx_rollup_remove_commitment Kind.manager case\n\n val tx_rollup_rejection_case : Kind.tx_rollup_rejection Kind.manager case\n\n val tx_rollup_dispatch_tickets_case :\n Kind.tx_rollup_dispatch_tickets Kind.manager case\n\n val transfer_ticket_case : Kind.transfer_ticket Kind.manager case\n\n val dal_publish_slot_header_case :\n Kind.dal_publish_slot_header Kind.manager case\n\n val register_global_constant_case :\n Kind.register_global_constant Kind.manager case\n\n val set_deposits_limit_case : Kind.set_deposits_limit Kind.manager case\n\n val increase_paid_storage_case :\n Kind.increase_paid_storage Kind.manager case\n\n val sc_rollup_originate_case : Kind.sc_rollup_originate Kind.manager case\n\n val sc_rollup_add_messages_case :\n Kind.sc_rollup_add_messages Kind.manager case\n\n val sc_rollup_cement_case : Kind.sc_rollup_cement Kind.manager case\n\n val sc_rollup_publish_case : Kind.sc_rollup_publish Kind.manager case\n\n val sc_rollup_refute_case : Kind.sc_rollup_refute Kind.manager case\n\n val sc_rollup_timeout_case : Kind.sc_rollup_timeout Kind.manager case\n\n val sc_rollup_execute_outbox_message_case :\n Kind.sc_rollup_execute_outbox_message Kind.manager case\n\n val sc_rollup_recover_bond_case :\n Kind.sc_rollup_recover_bond Kind.manager case\n\n val zk_rollup_origination_case :\n Kind.zk_rollup_origination Kind.manager case\n\n val zk_rollup_publish_case : Kind.zk_rollup_publish Kind.manager case\n\n val zk_rollup_update_case : Kind.zk_rollup_update Kind.manager case\n\n module Manager_operations : sig\n type 'b case =\n | MCase : {\n tag : int;\n name : string;\n encoding : 'a Data_encoding.t;\n select : packed_manager_operation -> 'kind manager_operation option;\n proj : 'kind manager_operation -> 'a;\n inj : 'a -> 'kind manager_operation;\n }\n -> 'kind case\n\n val reveal_case : Kind.reveal case\n\n val transaction_case : Kind.transaction case\n\n val origination_case : Kind.origination case\n\n val delegation_case : Kind.delegation case\n\n val update_consensus_key_tag : int\n\n val update_consensus_key_case : Kind.update_consensus_key case\n\n val register_global_constant_case : Kind.register_global_constant case\n\n val set_deposits_limit_case : Kind.set_deposits_limit case\n\n val increase_paid_storage_case : Kind.increase_paid_storage case\n\n val tx_rollup_origination_case : Kind.tx_rollup_origination case\n\n val tx_rollup_submit_batch_case : Kind.tx_rollup_submit_batch case\n\n val tx_rollup_commit_case : Kind.tx_rollup_commit case\n\n val tx_rollup_return_bond_case : Kind.tx_rollup_return_bond case\n\n val tx_rollup_finalize_commitment_case :\n Kind.tx_rollup_finalize_commitment case\n\n val tx_rollup_remove_commitment_case :\n Kind.tx_rollup_remove_commitment case\n\n val tx_rollup_rejection_case : Kind.tx_rollup_rejection case\n\n val tx_rollup_dispatch_tickets_case : Kind.tx_rollup_dispatch_tickets case\n\n val transfer_ticket_case : Kind.transfer_ticket case\n\n val dal_publish_slot_header_case : Kind.dal_publish_slot_header case\n\n val sc_rollup_originate_case : Kind.sc_rollup_originate case\n\n val sc_rollup_add_messages_case : Kind.sc_rollup_add_messages case\n\n val sc_rollup_cement_case : Kind.sc_rollup_cement case\n\n val sc_rollup_publish_case : Kind.sc_rollup_publish case\n\n val sc_rollup_refute_case : Kind.sc_rollup_refute case\n\n val sc_rollup_timeout_case : Kind.sc_rollup_timeout case\n\n val sc_rollup_execute_outbox_message_case :\n Kind.sc_rollup_execute_outbox_message case\n\n val sc_rollup_recover_bond_case : Kind.sc_rollup_recover_bond case\n\n val zk_rollup_origination_case : Kind.zk_rollup_origination case\n\n val zk_rollup_publish_case : Kind.zk_rollup_publish case\n\n val zk_rollup_update_case : Kind.zk_rollup_update case\n end\n end\n\n val of_list : packed_contents list -> packed_contents_list tzresult\n\n val to_list : packed_contents_list -> packed_contents list\nend\n\n(** This module re-exports definitions from {!Stake_storage},\n {!Delegate_storage} and {!Delegate}. *)\nmodule Stake_distribution : sig\n val snapshot : context -> context tzresult Lwt.t\n\n val compute_snapshot_index :\n context -> Cycle.t -> max_snapshot_index:int -> int tzresult Lwt.t\n\n val baking_rights_owner :\n context ->\n Level.t ->\n round:Round.t ->\n (context * Slot.t * Consensus_key.pk) tzresult Lwt.t\n\n val slot_owner :\n context -> Level.t -> Slot.t -> (context * Consensus_key.pk) tzresult Lwt.t\nend\n\n(** This module re-exports definitions from {!Commitment_repr} and,\n {!Commitment_storage}. *)\nmodule Commitment : sig\n type t = {\n blinded_public_key_hash : Blinded_public_key_hash.t;\n amount : Tez.tez;\n }\n\n (** See {!Commitment_storage.exists}. *)\n val exists : context -> Blinded_public_key_hash.t -> bool Lwt.t\n\n val encoding : t Data_encoding.t\nend\n\n(** This module re-exports definitions from {!Bootstrap_storage}. *)\nmodule Bootstrap : sig\n val cycle_end : context -> Cycle.t -> context tzresult Lwt.t\nend\n\n(** This module re-exports definitions from {!Migration_repr}. *)\nmodule Migration : sig\n type origination_result = {\n balance_updates : Receipt.balance_updates;\n originated_contracts : Contract_hash.t list;\n storage_size : Z.t;\n paid_storage_size_diff : Z.t;\n }\nend\n\n(** Create an [Alpha_context.t] from an untyped context (first block in the chain only). *)\nval prepare_first_block :\n Chain_id.t ->\n Context.t ->\n typecheck:\n (context ->\n Script.t ->\n ((Script.t * Lazy_storage.diffs option) * context) tzresult Lwt.t) ->\n level:Int32.t ->\n timestamp:Time.t ->\n predecessor:Block_hash.t ->\n context tzresult Lwt.t\n\n(** Create an [Alpha_context.t] from an untyped context. *)\nval prepare :\n Context.t ->\n level:Int32.t ->\n predecessor_timestamp:Time.t ->\n timestamp:Time.t ->\n (context * Receipt.balance_updates * Migration.origination_result list)\n tzresult\n Lwt.t\n\n(** All the definitions below are re-exported from {!Raw_context}. *)\n\nval activate : context -> Protocol_hash.t -> context Lwt.t\n\nval reset_internal_nonce : context -> context\n\nval fresh_internal_nonce : context -> (context * int) tzresult\n\nval record_internal_nonce : context -> int -> context\n\nval internal_nonce_already_recorded : context -> int -> bool\n\nval description : context Storage_description.t\n\nval record_non_consensus_operation_hash : context -> Operation_hash.t -> context\n\nval non_consensus_operations : context -> Operation_hash.t list\n\nval record_dictator_proposal_seen : t -> t\n\nval dictator_proposal_seen : t -> bool\n\n(** Finalize an {{!t} [Alpha_context.t]}, producing a [validation_result].\n *)\nval finalize :\n ?commit_message:string -> context -> Fitness.raw -> Updater.validation_result\n\n(** Should only be used by [Main.current_context] to return a context usable for RPCs *)\nval current_context : context -> Context.t\n\n(** This module re-exports definitions from {!Parameters_repr}. *)\nmodule Parameters : sig\n type bootstrap_account = {\n public_key_hash : public_key_hash;\n public_key : public_key option;\n amount : Tez.t;\n delegate_to : public_key_hash option;\n consensus_key : public_key option;\n }\n\n type bootstrap_contract = {\n delegate : public_key_hash option;\n amount : Tez.t;\n script : Script.t;\n }\n\n type t = {\n bootstrap_accounts : bootstrap_account list;\n bootstrap_contracts : bootstrap_contract list;\n commitments : Commitment.t list;\n constants : Constants.Parametric.t;\n security_deposit_ramp_up_cycles : int option;\n no_reward_cycles : int option;\n }\n\n val bootstrap_account_encoding : bootstrap_account Data_encoding.t\n\n val encoding : t Data_encoding.t\nend\n\n(** This module re-exports definitions from {!Liquidity_baking_repr} and\n {!Liquidity_baking_storage}. *)\nmodule Liquidity_baking : sig\n type liquidity_baking_toggle_vote =\n Liquidity_baking_repr.liquidity_baking_toggle_vote =\n | LB_on\n | LB_off\n | LB_pass\n\n val liquidity_baking_toggle_vote_encoding :\n liquidity_baking_toggle_vote Data_encoding.encoding\n\n val get_cpmm_address : context -> Contract_hash.t tzresult Lwt.t\n\n module Toggle_EMA : sig\n type t\n\n val zero : t\n\n val to_int32 : t -> Int32.t\n\n val encoding : t Data_encoding.t\n end\n\n val on_subsidy_allowed :\n context ->\n toggle_vote:liquidity_baking_toggle_vote ->\n (context -> Contract_hash.t -> (context * 'a list) tzresult Lwt.t) ->\n (context * 'a list * Toggle_EMA.t) tzresult Lwt.t\nend\n\n(** This module re-exports definitions from {!Ticket_storage}. *)\nmodule Ticket_balance : sig\n type error +=\n | Negative_ticket_balance of {key : Ticket_hash.t; balance : Z.t}\n | Used_storage_space_underflow\n\n val adjust_balance :\n context -> Ticket_hash.t -> delta:Z.t -> (Z.t * context) tzresult Lwt.t\n\n val adjust_storage_space :\n context -> storage_diff:Z.t -> (Z.t * context) tzresult Lwt.t\n\n val get_balance :\n context -> Ticket_hash.t -> (Z.t option * context) tzresult Lwt.t\n\n (** This module discloses definitions that are only useful for tests and\n must not be used otherwise. *)\n module Internal_for_tests : sig\n val used_storage_space : context -> Z.t tzresult Lwt.t\n\n val paid_storage_space : context -> Z.t tzresult Lwt.t\n end\nend\n\nmodule First_level_of_protocol : sig\n (** Get the level of the first block of this protocol. *)\n val get : context -> Raw_level.t tzresult Lwt.t\nend\n\n(** This module re-exports definitions from {!Raw_context.Consensus}. *)\nmodule Consensus : sig\n include\n Raw_context.CONSENSUS\n with type t := t\n and type slot := Slot.t\n and type 'a slot_map := 'a Slot.Map.t\n and type slot_set := Slot.Set.t\n and type round := Round.t\n and type consensus_pk := Consensus_key.pk\n\n (** [store_endorsement_branch context branch] sets the \"endorsement branch\"\n (see {!Storage.Tenderbake.Endorsement_branch} to [branch] in both the disk\n storage and RAM. *)\n val store_endorsement_branch :\n context -> Block_hash.t * Block_payload_hash.t -> context Lwt.t\n\n (** [store_grand_parent_branch context branch] sets the \"grand-parent branch\"\n (see {!Storage.Tenderbake.Grand_parent_branch} to [branch] in both the\n disk storage and RAM. *)\n val store_grand_parent_branch :\n context -> Block_hash.t * Block_payload_hash.t -> context Lwt.t\nend\n\n(** This module re-exports definitions from {!Token}. *)\nmodule Token : sig\n type container =\n [ `Contract of Contract.t\n | `Collected_commitments of Blinded_public_key_hash.t\n | `Delegate_balance of public_key_hash\n | `Frozen_deposits of public_key_hash\n | `Block_fees\n | `Frozen_bonds of Contract.t * Bond_id.t ]\n\n type source =\n [ `Invoice\n | `Bootstrap\n | `Initial_commitments\n | `Revelation_rewards\n | `Double_signing_evidence_rewards\n | `Endorsing_rewards\n | `Baking_rewards\n | `Baking_bonuses\n | `Minted\n | `Liquidity_baking_subsidies\n | `Tx_rollup_rejection_rewards\n | `Sc_rollup_refutation_rewards\n | container ]\n\n type sink =\n [ `Storage_fees\n | `Double_signing_punishments\n | `Lost_endorsing_rewards of public_key_hash * bool * bool\n | `Burned\n | `Tx_rollup_rejection_punishments\n | `Sc_rollup_refutation_punishments\n | container ]\n\n val allocated : context -> container -> (context * bool) tzresult Lwt.t\n\n val balance : context -> container -> (context * Tez.t) tzresult Lwt.t\n\n val transfer_n :\n ?origin:Receipt.update_origin ->\n context ->\n ([< source] * Tez.t) list ->\n [< sink] ->\n (context * Receipt.balance_updates) tzresult Lwt.t\n\n val transfer :\n ?origin:Receipt.update_origin ->\n context ->\n [< source] ->\n [< sink] ->\n Tez.t ->\n (context * Receipt.balance_updates) tzresult Lwt.t\nend\n\n(** This module re-exports definitions from {!Fees_storage}. *)\nmodule Fees : sig\n val record_paid_storage_space :\n context -> Contract_hash.t -> (context * Z.t * Z.t) tzresult Lwt.t\n\n val record_global_constant_storage_space : context -> Z.t -> context * Z.t\n\n val burn_storage_fees :\n ?origin:Receipt.update_origin ->\n context ->\n storage_limit:Z.t ->\n payer:Token.source ->\n Z.t ->\n (context * Z.t * Receipt.balance_updates) tzresult Lwt.t\n\n val burn_storage_increase_fees :\n ?origin:Receipt_repr.update_origin ->\n context ->\n payer:Token.source ->\n Z.t ->\n (context * Receipt.balance_updates) tzresult Lwt.t\n\n val burn_origination_fees :\n ?origin:Receipt.update_origin ->\n context ->\n storage_limit:Z.t ->\n payer:Token.source ->\n (context * Z.t * Receipt.balance_updates) tzresult Lwt.t\n\n val burn_tx_rollup_origination_fees :\n ?origin:Receipt.update_origin ->\n context ->\n storage_limit:Z.t ->\n payer:Token.source ->\n (context * Z.t * Receipt.balance_updates) tzresult Lwt.t\n\n val burn_sc_rollup_origination_fees :\n ?origin:Receipt.update_origin ->\n context ->\n storage_limit:Z.t ->\n payer:Token.source ->\n Z.t ->\n (context * Z.t * Receipt.balance_updates) tzresult Lwt.t\n\n val burn_zk_rollup_origination_fees :\n ?origin:Receipt.update_origin ->\n context ->\n storage_limit:Z.t ->\n payer:Token.source ->\n Z.t ->\n (context * Z.t * Receipt.balance_updates) tzresult Lwt.t\n\n type error += Cannot_pay_storage_fee (* `Temporary *)\n\n type error += Operation_quota_exceeded (* `Temporary *)\n\n type error += Storage_limit_too_high (* `Permanent *)\n\n val check_storage_limit : context -> storage_limit:Z.t -> unit tzresult\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2019-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2021-2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t = Raw_context.t\n\ntype context = t\n\nmodule type BASIC_DATA = sig\n type t\n\n include Compare.S with type t := t\n\n val encoding : t Data_encoding.t\n\n val pp : Format.formatter -> t -> unit\nend\n\nmodule Tez = Tez_repr\nmodule Period = Period_repr\n\nmodule Timestamp = struct\n include Time_repr\n\n let current = Raw_context.current_timestamp\n\n let predecessor = Raw_context.predecessor_timestamp\nend\n\nmodule Slot = Slot_repr\nmodule Sc_rollup_repr = Sc_rollup_repr\n\nmodule Sc_rollup = struct\n module Tick = Sc_rollup_tick_repr\n include Sc_rollup_repr\n module Metadata = Sc_rollup_metadata_repr\n module Dissection_chunk = Sc_rollup_dissection_chunk_repr\n include Sc_rollup_PVM_sig\n module ArithPVM = Sc_rollup_arith\n module Wasm_2_0_0PVM = Sc_rollup_wasm.V2_0_0\n module Inbox_message = Sc_rollup_inbox_message_repr\n module Inbox_merkelized_payload_hashes =\n Sc_rollup_inbox_merkelized_payload_hashes_repr\n\n module Staker = struct\n include Sc_rollup_repr.Staker\n module Index = Sc_rollup_staker_index_repr\n end\n\n module Inbox = struct\n include Sc_rollup_inbox_repr\n include Sc_rollup_inbox_storage\n\n module Internal_for_tests = struct\n include Sc_rollup_inbox_repr.Internal_for_tests\n include Sc_rollup_inbox_storage.Internal_for_tests\n end\n end\n\n module Proof = Sc_rollup_proof_repr\n module Game = Sc_rollup_game_repr\n\n module Commitment = struct\n include Sc_rollup_commitment_repr\n include Sc_rollup_commitment_storage\n end\n\n module Stake_storage = struct\n include Sc_rollup_stake_storage\n end\n\n module Refutation_storage = Sc_rollup_refutation_storage\n include Sc_rollup_storage\n include Sc_rollups\n\n module Outbox = struct\n include Sc_rollup_outbox_storage\n module Message = Sc_rollup_outbox_message_repr\n end\n\n module Errors = Sc_rollup_errors\nend\n\nmodule Dal = struct\n include Dal_slot_repr\n\n module Slot_index = struct\n include Dal_slot_repr.Index\n end\n\n module Attestation = struct\n include Dal_attestation_repr\n include Raw_context.Dal\n end\n\n type slot_id = Dal_slot_repr.Header.id = {\n published_level : Raw_level_repr.t;\n index : Dal_slot_repr.Index.t;\n }\n\n module Page = struct\n include Dal_slot_repr.Page\n end\n\n module Slot = struct\n include Dal_slot_repr\n include Dal_slot_storage\n include Raw_context.Dal\n end\n\n module Slots_history = Dal_slot_repr.History\n module Slots_storage = Dal_slot_storage\nend\n\nmodule Dal_errors = Dal_errors_repr\n\nmodule Zk_rollup = struct\n include Zk_rollup_repr\n module State = Zk_rollup_state_repr\n module Account = Zk_rollup_account_repr\n module Operation = Zk_rollup_operation_repr\n module Ticket = Zk_rollup_ticket_repr\n module Errors = Zk_rollup_errors\n module Circuit_public_inputs = Zk_rollup_circuit_public_inputs_repr\n module Update = Zk_rollup_update_repr\n include Zk_rollup_storage\nend\n\nmodule Entrypoint = Entrypoint_repr\nmodule Manager_counter = Manager_counter_repr\ninclude Operation_repr\n\nmodule Operation = struct\n type 'kind t = 'kind operation = {\n shell : Operation.shell_header;\n protocol_data : 'kind protocol_data;\n }\n\n type packed = packed_operation\n\n let unsigned_encoding = unsigned_operation_encoding\n\n include Operation_repr\nend\n\nmodule Block_header = Block_header_repr\n\nmodule Vote = struct\n include Vote_repr\n include Vote_storage\nend\n\nmodule Block_payload = struct\n include Block_payload_repr\nend\n\nmodule First_level_of_protocol = struct\n let get = Storage.Tenderbake.First_level_of_protocol.get\nend\n\nmodule Ratio = Ratio_repr\n\nmodule Raw_level = struct\n include Raw_level_repr\n\n module Internal_for_tests = struct\n let add = add\n\n let sub = sub\n end\nend\n\nmodule Cycle = Cycle_repr\nmodule Fees = Fees_storage\n\ntype public_key = Signature.Public_key.t\n\ntype public_key_hash = Signature.Public_key_hash.t\n\ntype signature = Signature.t\n\nmodule Constants = struct\n include Constants_repr\n include Constants_storage\n module Parametric = Constants_parametric_repr\n\n let round_durations ctxt = Raw_context.round_durations ctxt\n\n let all ctxt = all_of_parametric (parametric ctxt)\nend\n\nmodule Voting_period = struct\n include Voting_period_repr\n include Voting_period_storage\nend\n\nmodule Round = struct\n include Round_repr\n module Durations = Durations\n\n type round_durations = Durations.t\n\n let pp_round_durations = Durations.pp\n\n let round_durations_encoding = Durations.encoding\n\n let round_duration = Round_repr.Durations.round_duration\n\n let update ctxt round = Storage.Block_round.update ctxt round\n\n let get ctxt = Storage.Block_round.get ctxt\nend\n\nmodule Gas = struct\n include Gas_limit_repr\n\n type error += Block_quota_exceeded = Raw_context.Block_quota_exceeded\n\n type error += Operation_quota_exceeded = Raw_context.Operation_quota_exceeded\n\n let set_limit = Raw_context.set_gas_limit\n\n let consume_limit_in_block = Raw_context.consume_gas_limit_in_block\n\n let set_unlimited = Raw_context.set_gas_unlimited\n\n let consume = Raw_context.consume_gas\n\n let consume_from available_gas cost =\n match raw_consume available_gas cost with\n | Some remaining_gas -> ok remaining_gas\n | None -> error Operation_quota_exceeded\n\n let remaining_operation_gas = Raw_context.remaining_operation_gas\n\n let update_remaining_operation_gas =\n Raw_context.update_remaining_operation_gas\n\n let reset_block_gas ctxt =\n let gas = Arith.fp @@ Constants.hard_gas_limit_per_block ctxt in\n Raw_context.update_remaining_block_gas ctxt gas\n\n let level = Raw_context.gas_level\n\n let consumed = Raw_context.gas_consumed\n\n let block_level = Raw_context.block_gas_level\n\n (* Necessary to inject costs for Storage_costs into Gas.cost *)\n let cost_of_repr cost = cost\nend\n\nmodule Script = struct\n include Michelson_v1_primitives\n include Script_repr\n\n type consume_deserialization_gas = Always | When_needed\n\n let force_decode_in_context ~consume_deserialization_gas ctxt lexpr =\n let gas_cost =\n match consume_deserialization_gas with\n | Always -> Script_repr.stable_force_decode_cost lexpr\n | When_needed -> Script_repr.force_decode_cost lexpr\n in\n Raw_context.consume_gas ctxt gas_cost >>? fun ctxt ->\n Script_repr.force_decode lexpr >|? fun v -> (v, ctxt)\n\n let force_bytes_in_context ctxt lexpr =\n Raw_context.consume_gas ctxt (Script_repr.force_bytes_cost lexpr)\n >>? fun ctxt ->\n Script_repr.force_bytes lexpr >|? fun v -> (v, ctxt)\n\n let consume_decoding_gas available_gas lexpr =\n let gas_cost = Script_repr.stable_force_decode_cost lexpr in\n Gas.consume_from available_gas gas_cost\nend\n\nmodule Level = struct\n include Level_repr\n include Level_storage\nend\n\nmodule Lazy_storage = struct\n module Kind = Lazy_storage_kind\n module IdSet = Kind.IdSet\n include Lazy_storage_diff\nend\n\nmodule Origination_nonce = struct\n let init = Raw_context.init_origination_nonce\n\n let unset = Raw_context.unset_origination_nonce\n\n module Internal_for_tests = Origination_nonce\nend\n\nmodule Destination = struct\n include Destination_repr\n include Destination_storage\nend\n\nmodule Contract = struct\n include Contract_repr\n include Contract_storage\n\n let is_manager_key_revealed = Contract_manager_storage.is_manager_key_revealed\n\n let check_public_key = Contract_manager_storage.check_public_key\n\n let reveal_manager_key = Contract_manager_storage.reveal_manager_key\n\n let get_manager_key = Contract_manager_storage.get_manager_key\n\n module Delegate = struct\n let find = Contract_delegate_storage.find\n\n include Delegate_storage.Contract\n end\n\n module Internal_for_tests = struct\n include Contract_repr\n include Contract_storage\n end\nend\n\nmodule Tx_rollup_level = Tx_rollup_level_repr\nmodule Tx_rollup_commitment_hash = Tx_rollup_commitment_repr.Hash\nmodule Tx_rollup_message_result_hash = Tx_rollup_message_result_hash_repr\n\nmodule Tx_rollup = struct\n include Tx_rollup_repr\n include Tx_rollup_storage\n module Internal_for_tests = Tx_rollup_repr\nend\n\nmodule Tx_rollup_state = struct\n include Tx_rollup_state_repr\n include Tx_rollup_state_storage\n\n module Internal_for_tests = struct\n include Tx_rollup_state_repr\n include Tx_rollup_state_repr.Internal_for_tests\n end\nend\n\nmodule Tx_rollup_withdraw = Tx_rollup_withdraw_repr\nmodule Tx_rollup_withdraw_list_hash = Tx_rollup_withdraw_list_hash_repr\nmodule Tx_rollup_message_result = Tx_rollup_message_result_repr\n\nmodule Tx_rollup_reveal = struct\n include Tx_rollup_reveal_repr\n include Tx_rollup_reveal_storage\nend\n\nmodule Tx_rollup_message = struct\n include Tx_rollup_message_repr\n\n let make_message msg = (msg, size msg)\n\n let make_batch string = make_message @@ Batch string\n\n let make_deposit sender destination ticket_hash amount =\n make_message @@ Deposit {sender; destination; ticket_hash; amount}\nend\n\nmodule Tx_rollup_message_hash = Tx_rollup_message_hash_repr\n\nmodule Tx_rollup_inbox = struct\n include Tx_rollup_inbox_repr\n include Tx_rollup_inbox_storage\nend\n\nmodule Tx_rollup_commitment = struct\n include Tx_rollup_commitment_repr\n include Tx_rollup_commitment_storage\nend\n\nmodule Tx_rollup_hash = Tx_rollup_hash_builder\nmodule Tx_rollup_errors = Tx_rollup_errors_repr\nmodule Global_constants_storage = Global_constants_storage\n\nmodule Big_map = struct\n module Big_map = Lazy_storage_kind.Big_map\n\n module Id = struct\n type t = Big_map.Id.t\n\n let encoding = Big_map.Id.encoding\n\n let rpc_arg = Big_map.Id.rpc_arg\n\n let parse_z = Big_map.Id.parse_z\n\n let unparse_to_z = Big_map.Id.unparse_to_z\n end\n\n let fresh ~temporary c = Lazy_storage.fresh Big_map ~temporary c\n\n let mem c m k = Storage.Big_map.Contents.mem (c, m) k\n\n let get_opt c m k = Storage.Big_map.Contents.find (c, m) k\n\n let list_key_values ?offset ?length c m =\n Storage.Big_map.Contents.list_key_values ?offset ?length (c, m)\n\n let exists c id =\n Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost 0) >>?= fun c ->\n Storage.Big_map.Key_type.find c id >>=? fun kt ->\n match kt with\n | None -> return (c, None)\n | Some kt ->\n Storage.Big_map.Value_type.get c id >|=? fun kv -> (c, Some (kt, kv))\n\n type update = Big_map.update = {\n key : Script_repr.expr;\n key_hash : Script_expr_hash.t;\n value : Script_repr.expr option;\n }\n\n type updates = Big_map.updates\n\n type alloc = Big_map.alloc = {\n key_type : Script_repr.expr;\n value_type : Script_repr.expr;\n }\nend\n\nmodule Sapling = struct\n module Sapling_state = Lazy_storage_kind.Sapling_state\n\n module Id = struct\n type t = Sapling_state.Id.t\n\n let encoding = Sapling_state.Id.encoding\n\n let rpc_arg = Sapling_state.Id.rpc_arg\n\n let parse_z = Sapling_state.Id.parse_z\n\n let unparse_to_z = Sapling_state.Id.unparse_to_z\n end\n\n include Sapling_repr\n include Sapling_storage\n include Sapling_validator\n\n let fresh ~temporary c = Lazy_storage.fresh Sapling_state ~temporary c\n\n type updates = Sapling_state.updates\n\n type alloc = Sapling_state.alloc = {memo_size : Sapling_repr.Memo_size.t}\n\n module Legacy = struct\n include Sapling.UTXO.Legacy\n\n let transaction_get_memo_size transaction =\n match transaction.outputs with\n | [] -> None\n | {ciphertext; _} :: _ ->\n (* Encoding ensures all ciphertexts have the same memo size. *)\n Some (Sapling.Ciphertext.get_memo_size ciphertext)\n\n let transaction_in_memory_size transaction =\n transaction_in_memory_size (cast transaction)\n\n let verify_update ctxt state transaction key =\n verify_update ctxt state (cast transaction) key\n end\nend\n\nmodule Bond_id = struct\n include Bond_id_repr\n module Internal_for_tests = Contract_storage\nend\n\nmodule Receipt = Receipt_repr\nmodule Consensus_key = Delegate_consensus_key\n\nmodule Delegate = struct\n include Delegate_storage\n include Delegate_missed_endorsements_storage\n include Delegate_slashed_deposits_storage\n include Delegate_cycles\n\n type deposits = Storage.deposits = {\n initial_amount : Tez.t;\n current_amount : Tez.t;\n }\n\n let last_cycle_before_deactivation =\n Delegate_activation_storage.last_cycle_before_deactivation\n\n let prepare_stake_distribution = Stake_storage.prepare_stake_distribution\n\n let check_not_tz4 = Contract_delegate_storage.check_not_tz4\n\n let delegated_contracts = Contract_delegate_storage.delegated_contracts\n\n let deactivated = Delegate_activation_storage.is_inactive\n\n module Consensus_key = Delegate_consensus_key\nend\n\nmodule Stake_distribution = struct\n let snapshot = Stake_storage.snapshot\n\n let compute_snapshot_index = Delegate_sampler.compute_snapshot_index\n\n let baking_rights_owner = Delegate_sampler.baking_rights_owner\n\n let slot_owner = Delegate_sampler.slot_owner\nend\n\nmodule Nonce = Nonce_storage\n\nmodule Seed = struct\n include Seed_repr\n include Seed_storage\nend\n\nmodule Fitness = struct\n type raw = Fitness.t\n\n include Fitness_repr\nend\n\nmodule Bootstrap = Bootstrap_storage\n\nmodule Commitment = struct\n include Commitment_repr\n include Commitment_storage\nend\n\nmodule Migration = Migration_repr\n\nmodule Consensus = struct\n include Raw_context.Consensus\n\n let load_endorsement_branch ctxt =\n Storage.Tenderbake.Endorsement_branch.find ctxt >>=? function\n | Some endorsement_branch ->\n Raw_context.Consensus.set_endorsement_branch ctxt endorsement_branch\n |> return\n | None -> return ctxt\n\n let store_endorsement_branch ctxt branch =\n let ctxt = set_endorsement_branch ctxt branch in\n Storage.Tenderbake.Endorsement_branch.add ctxt branch\n\n let load_grand_parent_branch ctxt =\n Storage.Tenderbake.Grand_parent_branch.find ctxt >>=? function\n | Some grand_parent_branch ->\n Raw_context.Consensus.set_grand_parent_branch ctxt grand_parent_branch\n |> return\n | None -> return ctxt\n\n let store_grand_parent_branch ctxt branch =\n let ctxt = set_grand_parent_branch ctxt branch in\n Storage.Tenderbake.Grand_parent_branch.add ctxt branch\nend\n\nlet prepare_first_block = Init_storage.prepare_first_block\n\nlet prepare ctxt ~level ~predecessor_timestamp ~timestamp =\n Init_storage.prepare ctxt ~level ~predecessor_timestamp ~timestamp\n >>=? fun (ctxt, balance_updates, origination_results) ->\n Consensus.load_endorsement_branch ctxt >>=? fun ctxt ->\n Consensus.load_grand_parent_branch ctxt >>=? fun ctxt ->\n return (ctxt, balance_updates, origination_results)\n\nlet finalize ?commit_message:message c fitness =\n let context = Raw_context.recover c in\n {\n Updater.context;\n fitness;\n message;\n max_operations_ttl = (Raw_context.constants c).max_operations_time_to_live;\n last_allowed_fork_level =\n Raw_level.to_int32 @@ Level.last_allowed_fork_level c;\n }\n\nlet current_context c = Raw_context.recover c\n\nlet record_non_consensus_operation_hash =\n Raw_context.record_non_consensus_operation_hash\n\nlet non_consensus_operations = Raw_context.non_consensus_operations\n\nlet record_dictator_proposal_seen = Raw_context.record_dictator_proposal_seen\n\nlet dictator_proposal_seen = Raw_context.dictator_proposal_seen\n\nlet activate = Raw_context.activate\n\nlet reset_internal_nonce = Raw_context.reset_internal_nonce\n\nlet fresh_internal_nonce = Raw_context.fresh_internal_nonce\n\nlet record_internal_nonce = Raw_context.record_internal_nonce\n\nlet internal_nonce_already_recorded =\n Raw_context.internal_nonce_already_recorded\n\nlet description = Raw_context.description\n\nmodule Parameters = Parameters_repr\n\nmodule Liquidity_baking = struct\n include Liquidity_baking_repr\n include Liquidity_baking_storage\nend\n\nmodule Ticket_hash = struct\n include Ticket_hash_repr\n include Ticket_hash_builder\nend\n\nmodule Ticket_balance = struct\n include Ticket_storage\nend\n\nmodule Token = Token\nmodule Cache = Cache_repr\n\nmodule Internal_for_tests = struct\n let to_raw x = x\nend\n" ;
} ;
{ name = "Script_string" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Strings of printable characters *)\n\ntype repr\n\n(** [t] is made algebraic in order to distinguish it from the other type\n parameters of [Script_typed_ir.ty]. *)\ntype t = String_tag of repr [@@ocaml.unboxed]\n\ntype error += Non_printable_character of (int * string)\n\nval empty : t\n\nval of_string : string -> t tzresult\n\nval to_string : t -> string\n\nval compare : t -> t -> int\n\nval length : t -> int\n\nval concat_pair : t -> t -> t\n\nval concat : t list -> t\n\nval sub : t -> int -> int -> t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Strings of printable characters *)\n\ntype repr = string (* Invariant: contains only printable characters *)\n\ntype t = String_tag of repr [@@ocaml.unboxed]\n\ntype error += Non_printable_character of (int * string)\n\nlet () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.non_printable_character\"\n ~title:\"Non printable character in a Michelson string\"\n ~description:\n \"Michelson strings are only allowed to contain printable characters \\\n (either the newline character or characters in the [32, 126] ASCII \\\n range).\"\n ~pp:(fun ppf (pos, s) ->\n Format.fprintf\n ppf\n \"In Michelson string \\\"%s\\\", character at position %d has ASCII code \\\n %d. Expected: either a newline character (ASCII code 10) or a \\\n printable character (ASCII code between 32 and 126).\"\n s\n pos\n (Char.code s.[pos]))\n (obj2 (req \"position\" int31) (req \"string\" (string Plain)))\n (function Non_printable_character (pos, s) -> Some (pos, s) | _ -> None)\n (fun (pos, s) -> Non_printable_character (pos, s))\n\nlet empty = String_tag \"\"\n\nlet of_string v =\n let rec check_printable_ascii i =\n if Compare.Int.(i < 0) then ok (String_tag v)\n else\n match v.[i] with\n | '\\n' | '\\x20' .. '\\x7E' -> check_printable_ascii (i - 1)\n | _ -> error @@ Non_printable_character (i, v)\n in\n check_printable_ascii (String.length v - 1)\n\nlet to_string (String_tag s) = s\n\nlet compare (String_tag x) (String_tag y) = Compare.String.compare x y\n\nlet length (String_tag s) = String.length s\n\nlet concat_pair (String_tag x) (String_tag y) = String_tag (x ^ y)\n\nlet concat l =\n let l = List.map (fun (String_tag s) -> s) l in\n String_tag (String.concat \"\" l)\n\nlet sub (String_tag s) offset length = String_tag (String.sub s offset length)\n" ;
} ;
{ name = "Script_timestamp" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Defines the internal Michelson representation for timestamps and basic\n operations that can be performed on it. *)\n\nopen Script_int\n\ntype repr\n\n(** Representation of timestamps specific to the Michelson interpreter.\n A number of seconds since the epoch.\n [t] is made algebraic in order to distinguish it from the other type\n parameters of [Script_typed_ir.ty]. *)\ntype t = Timestamp_tag of repr [@@ocaml.unboxed]\n\n(** Convert a number of seconds since the epoch to a timestamp.*)\nval of_int64 : int64 -> t\n\n(** Compare timestamps. Returns [1] if the first timestamp is later than the\n second one; [0] if they're equal and [-1] othwerwise. *)\nval compare : t -> t -> int\n\n(** Convert a timestamp to RFC3339 notation if possible **)\nval to_notation : t -> string option\n\n(** Convert a timestamp to a string representation of the seconds *)\nval to_num_str : t -> string\n\n(** Convert to RFC3339 notation if possible, or num if not *)\nval to_string : t -> string\n\nval of_string : string -> t option\n\n(** Returns difference between timestamps as integral number of seconds\n in Michelson representation of numbers. *)\nval diff : t -> t -> z num\n\n(** Add a number of seconds to the timestamp. *)\nval add_delta : t -> z num -> t\n\n(** Subtract a number of seconds from the timestamp. *)\nval sub_delta : t -> z num -> t\n\nval to_zint : t -> Z.t\n\nval of_zint : Z.t -> t\n\n(* Timestamps are encoded exactly as Z. *)\nval encoding : t Data_encoding.encoding\n\nval now : Alpha_context.t -> t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype repr = Z.t\n\ntype t = Timestamp_tag of repr [@@ocaml.unboxed]\n\nlet compare (Timestamp_tag x) (Timestamp_tag y) = Z.compare x y\n\nlet of_int64 i = Timestamp_tag (Z.of_int64 i)\n\nlet of_string x =\n match Time_repr.of_notation x with\n | None -> Option.catch (fun () -> Timestamp_tag (Z.of_string x))\n | Some time -> Some (of_int64 (Time_repr.to_seconds time))\n\nlet to_notation (Timestamp_tag x) =\n Option.catch (fun () ->\n Time_repr.to_notation (Time.of_seconds (Z.to_int64 x)))\n\nlet to_num_str (Timestamp_tag x) = Z.to_string x\n\nlet to_string x = match to_notation x with None -> to_num_str x | Some s -> s\n\nlet diff (Timestamp_tag x) (Timestamp_tag y) = Script_int.of_zint @@ Z.sub x y\n\nlet sub_delta (Timestamp_tag t) delta =\n Timestamp_tag (Z.sub t (Script_int.to_zint delta))\n\nlet add_delta (Timestamp_tag t) delta =\n Timestamp_tag (Z.add t (Script_int.to_zint delta))\n\nlet to_zint (Timestamp_tag x) = x\n\nlet of_zint x = Timestamp_tag x\n\nlet encoding = Data_encoding.(conv to_zint of_zint z)\n\nlet now ctxt =\n let open Alpha_context in\n let first_delay = Period.to_seconds (Constants.minimal_block_delay ctxt) in\n let current_timestamp = Timestamp.predecessor ctxt in\n Time.add current_timestamp first_delay |> Timestamp.to_seconds |> of_int64\n" ;
} ;
{ name = "Script_bytes" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 DaiLambda, Inc. <contact@dailambda.jp> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Semantics of logical and bit-shift operators for bytes *)\n\n(** [bytes_or a b] returns the logical or'ed bytes of [a] and [b].\n If the arguments have different lengths, the shorter one is 0-padded\n on the left before the logical operation. For example:\n\n 0x1200 OR 0x34 = 0x1200 OR 0x0034 = 0x1234\n 0x0012 OR 0xff = 0x0012 OR 0x00ff = 0x00ff (instead of 0xff)\n*)\nval bytes_or : bytes -> bytes -> bytes\n\n(** [bytes_and a b] returns the logical and'ed bytes of [a] and [b].\n If the arguments have different lengths, the prefix of the longer one\n is removed to have the same length as the shorter one before the logical\n operation. For example:\n\n 0x1234 AND 0x30 = 0x34 AND 0x30 = 0x30\n 0x12f00f AND 0x0fff = 0xf00f AND 0x0fff = 0x000f (instead of 0x0f)\n*)\nval bytes_and : bytes -> bytes -> bytes\n\n(** [bytes_xor a b] returns the logical xor'ed bytes of [a] and [b].\n If the arguments have different lengths, the shorter one is 0-padded\n on the left before the logical operation. For example:\n\n 0x1200 XOR 0x34 = 0x1200 XOR 0x0034 = 0x1234\n 0x0012 XOR 0xff = 0x0012 XOR 0x00ff = 0x00ed (instead of 0xed)\n*)\nval bytes_xor : bytes -> bytes -> bytes\n\n(** [bytes_not a] returns the logical not'ed bytes of [a] with the same\n length of [a]. For example:\n\n NOT 0xff00 = 0x00ff (instead of 0xff)\n*)\nval bytes_not : bytes -> bytes\n\n(** [bytes_lsl bytes bits] returns the [bits] left shifted bytes of [bytes].\n If [bits] is more than 64000, it returns [None].\n\n The function always returns a longer bytes of the input if [bits]\n is not 0. For example:\n\n 0x12 LSL 1 = 0x0024 (instead of 0x24)\n 0x0012 LSL 9 = 0x00002400 (instead of 0x002400 or 0x2400)\n*)\nval bytes_lsl : bytes -> Script_int.n Script_int.num -> bytes option\n\n(** [bytes_lsr bytes bits] returns the [bits] right shifted bytes of [bytes].\n\n 0x1234 LSR 1 = 0x091a\n 0x1234 LSR 8 = 0x12 (instead of 0x0012)\n*)\nval bytes_lsr : bytes -> Script_int.n Script_int.num -> bytes\n\n(** Convert a natural number to bytes using big-endian encoding. *)\nval bytes_of_nat_be : Script_int.n Script_int.num -> bytes\n\n(** Convert bytes to a natural number using big-endian encoding. *)\nval nat_of_bytes_be : bytes -> Script_int.n Script_int.num\n\n(** Convert an integer to bytes using big-endian encoding.\n Negative numbers are handled by two's-complement. *)\nval bytes_of_int_be : Script_int.z Script_int.num -> bytes\n\n(** Convert bytes to an integer using big-endian encoding.\n Negative numbers are handled by two's-complement. *)\nval int_of_bytes_be : bytes -> Script_int.z Script_int.num\n\nmodule Conversion_BE : sig\n val bytes_of_nat_be : Z.t -> bytes option\n\n val nat_of_bytes_be : bytes -> Z.t\n\n val bytes_of_int_be : Z.t -> bytes\n\n val int_of_bytes_be : bytes -> Z.t\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 DaiLambda, Inc. <contact@dailambda.jp> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Bytes\n\nlet bytes_and = logand\n\nlet bytes_or = logor\n\nlet bytes_xor = logxor\n\nlet bytes_not = lognot\n\nlet bytes_lsl a n =\n (* We have to limit the number of shifts for LSL *)\n match Script_int.to_int n with\n | Some n when Compare.Int.(n <= 64000) -> Some (shift_left a n)\n | _ -> None\n\nlet bytes_lsr a n =\n (* No limit on the number of shifts for LSR *)\n match Script_int.to_int n with\n | None ->\n (* [LSR bytes max_int] can shift out completely the longest\n possible [bytes]. *)\n Bytes.empty\n | Some n -> shift_right a n\n\nmodule Conversion_BE : sig\n (** Convert a natural number to bytes using big-endian encoding.\n\n Returns [None] when the argument is negative.\n\n Examples:\n\n - [bytes_of_nat_be (Z.of_int 0x00) = Some Bytes.empty]\n - [bytes_of_nat_be (Z.of_int 0x01) = Some (Bytes.of_string \"\\x01\")]\n - [bytes_of_nat_be (Z.of_int 0xff) = Some (Bytes.of_string \"\\xff\")]\n - [bytes_of_nat_be (Z.of_int 0x100) = Some (Bytes.of_strnig \"\\x01\\x00\")]\n - [bytes_of_nat_be (Z.of_int (-1)) = None]\n *)\n val bytes_of_nat_be : Z.t -> bytes option\n\n (** Convert bytes to a natural number using big-endian encoding.\n\n Examples:\n\n - [nat_of_bytes_be Bytes.empty = Z.of_int 0x00]\n - [nat_of_bytes_be (Bytes.of_string \"\\x00\") = Z.of_int 0x00]\n - [nat_of_bytes_be (Bytes.of_string \"\\x01\") = Z.of_int 0x01]\n - [nat_of_bytes_be (Bytes.of_string \"\\x00\\x01\") = Z.of_int 0x01]\n - [nat_of_bytes_be (Bytes.of_string \"\\xff\") = Z.of_int 0xff]\n - [nat_of_bytes_be (Bytes.of_string \"\\x00\\x00\\xff\") = Z.of_int 0xff]\n - [nat_of_bytes_be (Bytes.of_string \"\\x01\\x00\") = Z.of_int 0x0100]\n *)\n val nat_of_bytes_be : bytes -> Z.t\n\n (** Convert an integer to bytes using big-endian encoding.\n Negative numbers are handled by two's-complement.\n\n Examples:\n\n - [bytes_of_int_be (Z.of_int 0x00) = Bytes.empty]\n - [bytes_of_int_be (Z.of_int 0x01) = Bytes.of_string \"\\x01\"]\n - [bytes_of_int_be (Z.of_int 0x7f) = Bytes.of_string \"\\x7f\"]\n - [bytes_of_int_be (Z.of_int (-0x80)) = Bytes.of_string \"\\x80\"]\n - [bytes_of_int_be (Z.of_int 0x80) = Bytes.of_string \"\\x00\\x80\"] (not [\"\\x80\"])\n - [bytes_of_int_be (Z.of_int (-0x81)) = Bytes.of_string \"\\xff\\x7f\"] (not [\"\\x7f\"])\n - [bytes_of_int_be (Z.of_int 0x8000) = Bytes.of_string \"\\x00\\x80\\x00\"], (not [\"\\x80\\x00\"])\n *)\n val bytes_of_int_be : Z.t -> bytes\n\n (** Convert bytes to an integer using big-endian encoding.\n Negative numbers are handled by two's-complement.\n\n Examples:\n\n - [int_of_bytes_be Bytes.empty = Z.of_int 0x00]\n - [int_of_bytes_be (Bytes.of_string \"\\x01\") = Z.of_int 0x01]\n - [int_of_bytes_be (Bytes.of_string \"\\x00\\x01\") = Z.of_int 0x01]\n - [int_of_bytes_be (Bytes.of_string \"\\x7f\") = Z.of_int 0x7f]\n - [int_of_bytes_be (Bytes.of_string \"\\x00\\x7f\") = Z.of_int 0x7f]\n - [int_of_bytes_be (Bytes.of_string \"\\x80\") = Z.of_int (-0x80)] (not [0x80])\n - [int_of_bytes_be (Bytes.of_string \"\\xff\\x80\") = Z.of_int (-0x80)]\n - [int_of_bytes_be (Bytes.of_string \"\\xff\\x8f\") = Z.of_int (-0x81)]\n *)\n val int_of_bytes_be : bytes -> Z.t\nend = struct\n let encode_nat_be nbytes default z =\n (* [nbytes] is the exact number of the bytes to encode [z].\n\n When encoding an integer to bytes, it is first converted to\n a natural number using 2's complement, and then sent to this function.\n [default] is the prefix byte which may be required for the integer\n encoding. [Some '\\000'] when the integer is zero or positive.\n [Some '\\255'] when negative.\n *)\n assert (Compare.Z.(z >= Z.zero)) ;\n (* [Z.to_bits] encodes zero and positive numbers in the little endian.\n The result string can be zero trailed to make its length multiple\n of 4 or 8.\n *)\n let string_le = Z.to_bits z in\n let slen = String.length string_le in\n (* If [slen = nbytes]:\n string_le aabbcc\n the final output ccbbaa\n\n else if [slen > nbytes]:\n string_le aabbcc0000\n the final output ccbbaa\n\n else if [slen < nbytes] and [default= Some DD]:\n This is to encode an integer which requires an extra byte.\n string_le aabbcc\n encoded DDccbbaa\n\n otherwise: error, which should not happen.\n *)\n Bytes.init nbytes (fun i ->\n let j = nbytes - i - 1 in\n if Compare.Int.(j >= slen) then\n Option.value_f default ~default:(fun () ->\n assert false (* it never happens *))\n else string_le.[j])\n\n let bytes_of_nat_be z =\n match Z.compare z Z.zero with\n | -1 -> None\n | 0 -> Some Bytes.empty\n | _ ->\n let nbits = Z.log2up (Z.succ z) in\n let nbytes = (nbits + 7) / 8 in\n Some (encode_nat_be nbytes None z)\n\n let bytes_of_int_be z =\n match Z.compare z Z.zero with\n | 0 -> Bytes.empty\n | 1 ->\n let nbits = Z.log2up (Z.succ z) + 1 (* The top bit must be 0 *) in\n let nbytes = (nbits + 7) / 8 in\n encode_nat_be nbytes (Some '\\000') z\n | _ ->\n let nbits = Z.log2up Z.(neg z) + 1 (* The top bit must be 1 *) in\n let nbytes = (nbits + 7) / 8 in\n let nbits' = nbytes * 8 in\n let z'' = Z.(add (shift_left one nbits') z) in\n encode_nat_be nbytes (Some '\\255') z''\n\n let nat_of_bytes_be bytes =\n (* [Z.of_bits] ignores trailing zeros *)\n let len = Bytes.length bytes in\n (* Z.of_bits uses little-endian encoding but we want a big-endian\n encoding so we reverse [bytes] while converting it to `string`. *)\n Z.of_bits @@ String.init len (fun i -> Bytes.get bytes (len - i - 1))\n\n let int_of_bytes_be bytes =\n let nbytes = Bytes.length bytes in\n if Compare.Int.(nbytes = 0) then Z.zero\n else\n let top_bit = Compare.Int.(Char.code (Bytes.get bytes 0) land 128 <> 0) in\n if top_bit then\n (* negative *)\n let z = nat_of_bytes_be bytes in\n let nbits = nbytes * 8 in\n Z.(sub z (shift_left one nbits))\n else nat_of_bytes_be bytes\nend\n\nopen Script_int\n\nlet bytes_of_nat_be (n : n num) =\n (* The function always succeeds since the argument is 0 or positive *)\n match Conversion_BE.bytes_of_nat_be @@ to_zint n with\n | Some bytes -> bytes\n | None -> assert false\n\nlet nat_of_bytes_be b = abs @@ of_zint @@ Conversion_BE.nat_of_bytes_be b\n\nlet bytes_of_int_be (z : z num) = Conversion_BE.bytes_of_int_be @@ to_zint z\n\nlet int_of_bytes_be b = of_zint @@ Conversion_BE.int_of_bytes_be b\n" ;
} ;
{ name = "Tx_rollup_l2_storage_sig" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxheadalpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module type is the minimal API a storage backend has to\n implement to be compatible with the [Tx_rollup] layer-2\n implementation.\n\n In a nutshell, the [Tx_rollup] only needs a simple key-value\n store, where both keys and values are raw bytes buffers. We build\n a type-safe abstraction on top of this simple (but potentially\n unsafe) interface in [Tx_rollup_l2_context]. *)\nmodule type STORAGE = sig\n (** The state of the storage.\n\n The API adopts a functional paradigm, where the [set] function\n returns a new state for the storage, and where it should be\n possible to reuse a previous state. *)\n type t\n\n (** The monad of the storage backend. *)\n type 'a m\n\n (** The necessary monadic operators the monad of the storage backend\n is required to provide. *)\n module Syntax : sig\n val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m\n\n val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m\n\n (** [fail err] shortcuts the current computation by raising an\n error.\n\n Said error can be handled with the [catch] combinator. *)\n val fail : error -> 'a m\n\n (** [catch p k h] tries to executes the monadic computation [p].\n If [p] terminates without an error, then its result is passed\n to the continuation [k]. On the contrary, if an error [err] is\n raised, it is passed to the error handler [h]. *)\n val catch : 'a m -> ('a -> 'b m) -> (error -> 'b m) -> 'b m\n\n (** [return x] is the simplest computation inside the monad [m] which simply\n computes [x] and nothing else. *)\n val return : 'a -> 'a m\n\n (** [list_fold_left_m f] is a monadic version of [List.fold_left\n f], wherein [f] is not a pure computation, but a computation\n in the monad [m]. *)\n val list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m\n end\n\n (** [get storage key] returns the value stored in [storage] for\n [key], if it exists. Returns [None] if it does not. *)\n val get : t -> bytes -> bytes option m\n\n (** [set storage key] computes a new state for the storage wherein\n the value associated to [key] is [value].\n\n [storage] is expected to remain usable and consistent even after\n the execution of [set]. *)\n val set : t -> bytes -> bytes -> t m\n\n (** [remove storage key] removes [key] from the [storage]. *)\n val remove : t -> bytes -> t m\nend\n" ;
} ;
{ name = "Tx_rollup_l2_context_sig" ;
interface = None ;
implementation = "(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxheadalpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype signature = Bls.t\n\nmodule Ticket_indexable = Indexable.Make (Alpha_context.Ticket_hash)\n\n(** An integer used to identified a layer-2 address. See\n {!Tx_rollup_l2_address.index}. *)\ntype address_index = Tx_rollup_l2_address.Indexable.index\n\n(** An integer used to identified a layer-1 ticket deposited in a\n transaction rollup. *)\ntype ticket_index = Ticket_indexable.index\n\n(** The metadata associated to a layer-2 address.\n\n The counter is an counter-measure against replay attack. Each\n operation is signed with an integer (its counter). The counter\n is incremented when the operation is applied. This prevents the\n operation to be applied once again, since its integer will not\n be in sync with the counter of the account. The choice of [int64]\n for the type of the counter theoretically prevents the rollup to\n an integer overflow. However, it can only happen if a single account\n makes more than [1.8446744e+19] operations. If an account sends 1000\n operations per seconds, it would take them more than 5845420\n centuries to achieve that.\n\n The [public_key] allows to authenticate the owner of the address,\n by verifying BLS signatures. *)\ntype metadata = {counter : int64; public_key : Bls.Public_key.t}\n\ntype error +=\n | Balance_too_low\n | Balance_overflow\n | Invalid_quantity\n | Unknown_address_index of address_index\n | Metadata_already_initialized of address_index\n | Too_many_l2_addresses\n | Too_many_l2_tickets\n | Counter_overflow\n\nlet () =\n let open Data_encoding in\n (* Unknown address index *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_unknown_address_index\"\n ~title:\"Unknown address index\"\n ~description:\"Tried to increment the counter of an unknown address index\"\n (obj1 (req \"index\" Tx_rollup_l2_address.Indexable.index_encoding))\n (function Unknown_address_index x -> Some x | _ -> None)\n (fun x -> Unknown_address_index x) ;\n (* Balance too low *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_balance_too_low\"\n ~title:\"Balance too low\"\n ~description:\n \"Tried to spend a ticket index from an index without the required balance\"\n empty\n (function Balance_too_low -> Some () | _ -> None)\n (fun () -> Balance_too_low) ;\n (* Balance overflow *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_balance_overflow\"\n ~title:\"Balance overflow\"\n ~description:\n \"Tried to credit a ticket index to an index to a new balance greater \\\n than the integer 32 limit\"\n empty\n (function Balance_overflow -> Some () | _ -> None)\n (fun () -> Balance_overflow) ;\n (* Invalid_quantity *)\n register_error_kind\n `Permanent\n ~id:\"tx_rollup_invalid_quantity\"\n ~title:\"Invalid quantity\"\n ~description:\n \"Tried to credit a ticket index to an index with a quantity non-strictly \\\n positive\"\n empty\n (function Invalid_quantity -> Some () | _ -> None)\n (fun () -> Invalid_quantity) ;\n (* Metadata already initialized *)\n register_error_kind\n `Branch\n ~id:\"tx_rollup_metadata_already_initialized\"\n ~title:\"Metadata already initiliazed\"\n ~description:\n \"Tried to initialize a metadata for an index which was already \\\n initiliazed\"\n (obj1 (req \"index\" Tx_rollup_l2_address.Indexable.index_encoding))\n (function Metadata_already_initialized x -> Some x | _ -> None)\n (fun x -> Metadata_already_initialized x) ;\n (* Too many l2 addresses associated *)\n register_error_kind\n `Branch\n ~id:\"tx_rollup_too_many_l2_addresses\"\n ~title:\"Too many l2 addresses\"\n ~description:\"The number of l2 addresses has reached the integer 32 limit\"\n empty\n (function Too_many_l2_addresses -> Some () | _ -> None)\n (fun () -> Too_many_l2_addresses) ;\n (* Too many l2 tickets associated *)\n register_error_kind\n `Branch\n ~id:\"tx_rollup_too_many_l2_tickets\"\n ~title:\"Too many l2 tickets\"\n ~description:\"The number of l2 tickets has reached the integer 32 limit\"\n empty\n (function Too_many_l2_tickets -> Some () | _ -> None)\n (fun () -> Too_many_l2_tickets) ;\n (* Counter overflow *)\n register_error_kind\n `Branch\n ~id:\"tx_rollup_counter_overflow\"\n ~title:\"Counter overflow\"\n ~description:\n \"Tried to increment the counter of an address and reached the integer 64 \\\n limit\"\n empty\n (function Counter_overflow -> Some () | _ -> None)\n (fun () -> Counter_overflow)\n\n(** This module type describes the API of the [Tx_rollup] context,\n which is used to implement the semantics of the L2 operations. *)\nmodule type CONTEXT = sig\n (** The state of the [Tx_rollup] context.\n\n The context provides a type-safe, functional API to interact\n with the state of a transaction rollup. The functions of this\n module, manipulating and creating values of type [t] are called\n \226\128\156context operations\226\128\157 afterwards. *)\n type t\n\n (** The monad used by the context.\n\n {b Note:} It is likely to be the monad of the underlying\n storage. In the case of the proof verifier, as it is expected to\n be run into the L1, the monad will also be used to perform gas\n accounting. This is why all the functions of this module type\n needs to be inside the monad [m]. *)\n type 'a m\n\n (** The necessary monadic operators the storage monad is required to\n provide. *)\n module Syntax : sig\n val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m\n\n val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m\n\n (** [let*?] is for binding the value from Result-only\n expressions into the storage monad. *)\n val ( let*? ) : ('a, error) result -> ('a -> 'b m) -> 'b m\n\n (** [fail err] shortcuts the current computation by raising an\n error.\n\n Said error can be handled with the [catch] combinator. *)\n val fail : error -> 'a m\n\n (** [catch p k h] tries to executes the monadic computation [p].\n If [p] terminates without an error, then its result is passed\n to the continuation [k]. On the contrary, if an error [err] is\n raised, it is passed to the error handler [h]. *)\n val catch : 'a m -> ('a -> 'b m) -> (error -> 'b m) -> 'b m\n\n (** [return x] is the simplest computation inside the monad [m] which simply\n computes [x] and nothing else. *)\n val return : 'a -> 'a m\n\n (** [list_fold_left_m f] is a monadic version of [List.fold_left\n f], wherein [f] is not a pure computation, but a computation\n in the monad [m]. *)\n val list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m\n\n (** [fail_unless cond err] raises [err] iff [cond] is [false]. *)\n val fail_unless : bool -> error -> unit m\n\n (** [fail_when cond err] raises [err] iff [cond] is [true]. *)\n val fail_when : bool -> error -> unit m\n end\n\n (** [bls_aggregate_verify] allows to verify the aggregated signature\n of a batch. *)\n val bls_verify : (Bls.Public_key.t * bytes) list -> signature -> bool m\n\n (** The metadata associated to an address. *)\n module Address_metadata : sig\n (** [get ctxt idx] returns the current metadata associated to the\n address indexed by [idx]. *)\n val get : t -> address_index -> metadata option m\n\n (** [incr_counter ctxt idx] increments the counter of the\n address indexed by [idx].\n\n This function can fail with [Counter_overflow] iff the counter\n has reached the [Int64.max_int] limit.\n\n This function can fail with [Unknown_address_index] if [idx]\n has not been associated with a layer-2 address already. *)\n val incr_counter : t -> address_index -> t m\n\n (** [init_with_public_key ctxt idx pk] initializes the metadata\n associated to the address indexed by [idx].\n\n This can fails with [Metadata_already_initialized] if this\n function has already been called with [idx]. *)\n val init_with_public_key : t -> address_index -> Bls.Public_key.t -> t m\n\n (**/**)\n\n module Internal_for_tests : sig\n val set : t -> address_index -> metadata -> t m\n end\n end\n\n (** Mapping between {!Tx_rollup_l2_address.address} and {!address_index}.\n\n Addresses are supposed to be associated to a {!address_index} in\n order to reduce the batches' size submitted from the layer1 to the\n layer2. Therefore, the first time an address is used in a layer2\n operation, we associate it to a address_index that should be use\n in future layer2 operations.\n *)\n module Address_index : sig\n (** [init_counter ctxt] writes the default counter (i.e. [0L]) in\n the context. *)\n val init_counter : t -> t m\n\n (** [get ctxt addr] returns the index associated to [addr], if\n any. *)\n val get : t -> Tx_rollup_l2_address.t -> address_index option m\n\n (** [get_or_associate_index ctxt addr] associates a fresh [address_index]\n to [addr], and returns it. If the [addr] has already been associated to\n an index, it returns it.\n It also returns the information on whether the index was created or\n already existed.\n\n This function can fail with [Too_many_l2_addresses] iff there\n is no fresh index available. *)\n val get_or_associate_index :\n t ->\n Tx_rollup_l2_address.t ->\n (t * [`Created | `Existed] * address_index) m\n\n (** [count ctxt] returns the number of addresses that have been\n involved in the transaction rollup. *)\n val count : t -> int32 m\n\n (**/**)\n\n module Internal_for_tests : sig\n (** [set ctxt count] sets the [count] in [ctxt]. It is used to test\n the behavior of [Too_many_l2_addresses]. *)\n val set_count : t -> int32 -> t m\n end\n end\n\n (** Mapping between {!Ticket_hash.t} and {!ticket_index}.\n\n Ticket hashes are supposed to be associated to a {!ticket_index} in\n order to reduce the batches' size submitted from the layer1 to the\n layer2. Therefore, the first time a ticket hash is used in a layer2\n operation, we associate it to a ticket_index that should be use\n in future layer2 operations.\n *)\n module Ticket_index : sig\n (** [init_counter ctxt] writes the default counter (i.e. [0L]) in\n the context. *)\n val init_counter : t -> t m\n\n (** [get ctxt ticket] returns the index associated to [ticket], if\n any. *)\n val get : t -> Alpha_context.Ticket_hash.t -> ticket_index option m\n\n (** [get_or_associate_index ctxt ticket] associates a fresh [ticket_index]\n to [ticket], and returns it. If the [ticket] has already been associated\n to an index, it returns it.\n It also returns the information on whether the index was created or\n already existed.\n\n This function can fail with [Too_many_l2_tickets] iff there\n is no fresh index available. *)\n val get_or_associate_index :\n t ->\n Alpha_context.Ticket_hash.t ->\n (t * [`Created | `Existed] * ticket_index) m\n\n (** [count ctxt] returns the number of tickets that have been\n involved in the transaction rollup. *)\n val count : t -> int32 m\n\n (**/**)\n\n module Internal_for_tests : sig\n (** [set_count ctxt count] sets the [count] in [ctxt]. It is used to test\n the behavior of [Too_many_l2_addresses]. *)\n val set_count : t -> int32 -> t m\n end\n end\n\n (** The ledger of the layer 2 where are registered the amount of a\n given ticket a L2 [account] has in its possession. *)\n module Ticket_ledger : sig\n (** [get ctxt tidx aidx] returns the quantity of tickets ([tidx]) [aidx]\n owns.\n\n {b Note:} It is the responsibility of the caller to verify that [aidx]\n and [tidx] have been associated to an address and\n a ticket respectively. The function will return zero when the address\n has no such ticket. *)\n val get : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t m\n\n (** [credit ctxt tidx aidx qty] updates the ledger to\n increase the number of tickets indexed by [tidx] the address\n [aidx] owns by [qty] units.\n\n This function can fail with [Balance_overflow] if adding\n [qty] to the current balance of [aidx] causes an integer\n overflow.\n\n This function can fail with [Invalid_quantity] if [qty]\n is not strictly positive.\n\n {b Note:} It is the responsibility of the caller to verify that [aidx]\n and [tidx] have been associated to an address and\n a ticket respectively. *)\n val credit : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t -> t m\n\n (** [spend ctxt tidx aidx qty] updates the ledger to\n decrease the number of tickets indexed by [tidx] the address\n [aidx] owns by [qty] units.\n\n This function can fail with [Balance_too_low] if [aidx]\n does not own at least [qty] ticket.\n\n {b Note:} It is the responsibility of the caller to verify\n that [aidx] and [tidx] have been associated to an address and\n a ticket respectively. *)\n val spend : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t -> t m\n\n module Internal_for_tests : sig\n val get_opt :\n t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t option m\n end\n end\nend\n" ;
} ;
{ name = "Tx_rollup_l2_context" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxheadalpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Tx_rollup_l2_storage_sig\nopen Tx_rollup_l2_context_sig\n\nlet metadata_encoding =\n Data_encoding.(\n conv\n (fun {counter; public_key} -> (counter, public_key))\n (fun (counter, public_key) -> {counter; public_key})\n (obj2 (req \"counter\" int64) (req \"public_key\" Bls.Public_key.encoding)))\n\n(** {1 Type-Safe Storage Access and Gas Accounting} *)\n\n(** A value of type ['a key] identifies a value of type ['a] in an\n underlying, untyped storage.\n\n This GADT is used to enforce type-safety of the abstraction of\n the transactions rollup context. For this abstraction to work,\n it is necessary to ensure that the serialization of values ['a\n key] and ['b key] cannot collide. To that end, we use\n [Data_encoding] (see {!packed_key_encoding}). *)\ntype _ key =\n | Address_metadata : address_index -> metadata key\n | Address_count : int32 key\n | Address_index : Tx_rollup_l2_address.t -> address_index key\n | Ticket_count : int32 key\n | Ticket_index : Alpha_context.Ticket_hash.t -> ticket_index key\n | Ticket_ledger : ticket_index * address_index -> Tx_rollup_l2_qty.t key\n\n(** A monomorphic version of {!Key}, used for serialization purposes. *)\ntype packed_key = Key : 'a key -> packed_key\n\n(** The encoding used to serialize keys to be used with an untyped storage. *)\nlet packed_key_encoding : packed_key Data_encoding.t =\n Data_encoding.(\n union\n ~tag_size:`Uint8\n [\n case\n (Tag 0)\n ~title:\"Address_metadata\"\n Tx_rollup_l2_address.Indexable.index_encoding\n (function Key (Address_metadata idx) -> Some idx | _ -> None)\n (fun idx -> Key (Address_metadata idx));\n case\n (Tag 1)\n ~title:\"Address_count\"\n empty\n (function Key Address_count -> Some () | _ -> None)\n (fun () -> Key Address_count);\n case\n (Tag 2)\n ~title:\"Address_index\"\n Tx_rollup_l2_address.encoding\n (function Key (Address_index addr) -> Some addr | _ -> None)\n (fun addr -> Key (Address_index addr));\n case\n (Tag 3)\n ~title:\"Ticket_count\"\n empty\n (function Key Ticket_count -> Some () | _ -> None)\n (fun () -> Key Ticket_count);\n case\n (Tag 4)\n ~title:\"Ticket_index\"\n Alpha_context.Ticket_hash.encoding\n (function Key (Ticket_index ticket) -> Some ticket | _ -> None)\n (fun ticket -> Key (Ticket_index ticket));\n case\n (Tag 5)\n ~title:\"Ticket_ledger\"\n (tup2\n Ticket_indexable.index_encoding\n Tx_rollup_l2_address.Indexable.index_encoding)\n (function\n | Key (Ticket_ledger (ticket, address)) -> Some (ticket, address)\n | _ -> None)\n (fun (ticket, address) -> Key (Ticket_ledger (ticket, address)));\n ])\n\n(** [value_encoding key] returns the encoding to be used to serialize\n and deserialize values associated to a [key] from and to the\n underlying storage. *)\nlet value_encoding : type a. a key -> a Data_encoding.t =\n let open Data_encoding in\n function\n | Address_metadata _ -> metadata_encoding\n | Address_count -> int32\n | Address_index _ -> Tx_rollup_l2_address.Indexable.index_encoding\n | Ticket_count -> int32\n | Ticket_index _ -> Ticket_indexable.index_encoding\n | Ticket_ledger _ -> Tx_rollup_l2_qty.encoding\n\n(** {1 Errors} *)\n\ntype error += Key_cannot_be_serialized\n\ntype error += Value_cannot_be_serialized\n\ntype error += Value_cannot_be_deserialized\n\nlet () =\n let open Data_encoding in\n (* Key cannot be serialized *)\n register_error_kind\n `Permanent\n ~id:\"tx_rollup_key_cannot_be_serialized\"\n ~title:\"Key cannot be serialized\"\n ~description:\"Tried to serialize an invalid key.\"\n empty\n (function Key_cannot_be_serialized -> Some () | _ -> None)\n (fun () -> Key_cannot_be_serialized) ;\n (* Value cannot be serialized *)\n register_error_kind\n `Permanent\n ~id:\"tx_rollup_value_cannot_be_serialized\"\n ~title:\"Value cannot be serialized\"\n ~description:\"Tried to serialize an invalid value.\"\n empty\n (function Value_cannot_be_serialized -> Some () | _ -> None)\n (fun () -> Value_cannot_be_serialized) ;\n (* Value cannot be deserialized *)\n register_error_kind\n `Permanent\n ~id:\"tx_rollup_value_cannot_be_deserialized\"\n ~title:\"Value cannot be deserialized\"\n ~description:\n \"A value has been serialized in the Tx_rollup store, but cannot be \\\n deserialized.\"\n empty\n (function Value_cannot_be_deserialized -> Some () | _ -> None)\n (fun () -> Value_cannot_be_deserialized)\n\n(** {1 The Context Functor} *)\n\nmodule Make (S : STORAGE) : CONTEXT with type t = S.t and type 'a m = 'a S.m =\nstruct\n type t = S.t\n\n type 'a m = 'a S.m\n\n module Syntax = struct\n include S.Syntax\n\n let ( let*? ) res f =\n match res with Result.Ok v -> f v | Result.Error error -> fail error\n\n let fail_unless cond error =\n let open S.Syntax in\n if cond then return () else fail error\n\n let fail_when cond error =\n let open S.Syntax in\n if cond then fail error else return ()\n end\n\n let bls_verify : (Bls.Public_key.t * bytes) list -> signature -> bool m =\n fun accounts aggregated_signature ->\n let open Syntax in\n let msgs = List.map (fun (pk, msg) -> (pk, None, msg)) accounts in\n return (Bls.aggregate_check msgs aggregated_signature)\n\n let unwrap_or : type a. a option -> error -> a S.m =\n fun opt err ->\n match opt with Some x -> S.Syntax.return x | None -> S.Syntax.fail err\n\n let serialize_key : type a. a key -> bytes m =\n fun key ->\n unwrap_or\n (Data_encoding.Binary.to_bytes_opt packed_key_encoding (Key key))\n Key_cannot_be_serialized\n\n let serialize_value : type a. a Data_encoding.t -> a -> bytes m =\n fun encoding value ->\n unwrap_or\n (Data_encoding.Binary.to_bytes_opt encoding value)\n Value_cannot_be_serialized\n\n let deserialize_value : type a. a Data_encoding.t -> bytes -> a m =\n fun encoding value ->\n unwrap_or\n (Data_encoding.Binary.of_bytes_opt encoding value)\n Value_cannot_be_deserialized\n\n (** [get ctxt key] is a type-safe [get] function. *)\n let get : type a. t -> a key -> a option m =\n fun ctxt key ->\n let open Syntax in\n let value_encoding = value_encoding key in\n let* key = serialize_key key in\n let* value = S.get ctxt key in\n match value with\n | Some value ->\n let* value = deserialize_value value_encoding value in\n return (Some value)\n | None -> return None\n\n (** [set ctxt key value] is a type-safe [set] function. *)\n let set : type a. t -> a key -> a -> t m =\n fun ctxt key value ->\n let open Syntax in\n let value_encoding = value_encoding key in\n let* key = serialize_key key in\n let* value = serialize_value value_encoding value in\n S.set ctxt key value\n\n let remove : type a. t -> a key -> t m =\n fun ctxt key ->\n let open Syntax in\n let* key = serialize_key key in\n S.remove ctxt key\n\n module Address_metadata = struct\n let get ctxt idx = get ctxt (Address_metadata idx)\n\n let incr_counter ctxt idx =\n let open Syntax in\n let* metadata = get ctxt idx in\n match metadata with\n | Some meta ->\n let new_counter = Int64.succ meta.counter in\n let* () =\n fail_unless\n Compare.Int64.(new_counter >= meta.counter)\n Counter_overflow\n in\n set ctxt (Address_metadata idx) {meta with counter = new_counter}\n | None -> fail (Unknown_address_index idx)\n\n let init_with_public_key ctxt idx public_key =\n let open Syntax in\n let* metadata = get ctxt idx in\n match metadata with\n | None -> set ctxt (Address_metadata idx) {counter = 0L; public_key}\n | Some _ -> fail (Metadata_already_initialized idx)\n\n module Internal_for_tests = struct\n let set ctxt idx metadata = set ctxt (Address_metadata idx) metadata\n end\n end\n\n module Address_index = struct\n let count ctxt =\n let open Syntax in\n let+ count = get ctxt Address_count in\n Option.value ~default:0l count\n\n let init_counter ctxt = set ctxt Address_count 0l\n\n let associate_index ctxt addr =\n let open Syntax in\n let* i = count ctxt in\n let new_count = Int32.succ i in\n let* () =\n fail_unless Compare.Int32.(new_count >= i) Too_many_l2_addresses\n in\n (* This can not fail as by construction [count ctxt] is always positive. *)\n let idx = Indexable.index_exn i in\n let* ctxt = set ctxt (Address_index addr) idx in\n let+ ctxt = set ctxt Address_count new_count in\n (ctxt, idx)\n\n let get ctxt addr = get ctxt (Address_index addr)\n\n let get_or_associate_index ctxt addr =\n let open Syntax in\n let* index_opt = get ctxt addr in\n match index_opt with\n | Some idx -> return (ctxt, `Existed, idx)\n | None ->\n let+ ctxt, idx = associate_index ctxt addr in\n (ctxt, `Created, idx)\n\n module Internal_for_tests = struct\n let set_count ctxt count = set ctxt Address_count count\n end\n end\n\n module Ticket_index = struct\n let count ctxt =\n let open Syntax in\n let+ count = get ctxt Ticket_count in\n Option.value ~default:0l count\n\n let init_counter ctxt = set ctxt Ticket_count 0l\n\n let associate_index ctxt ticket =\n let open Syntax in\n let* i = count ctxt in\n let new_count = Int32.succ i in\n let* () =\n fail_unless Compare.Int32.(new_count >= i) Too_many_l2_tickets\n in\n (* This can not fail as by construction [count ctxt] is always positive. *)\n let idx = Indexable.index_exn i in\n let* ctxt = set ctxt (Ticket_index ticket) idx in\n let+ ctxt = set ctxt Ticket_count new_count in\n (ctxt, idx)\n\n let get ctxt ticket = get ctxt (Ticket_index ticket)\n\n let get_or_associate_index ctxt ticket =\n let open Syntax in\n let* index_opt = get ctxt ticket in\n match index_opt with\n | Some idx -> return (ctxt, `Existed, idx)\n | None ->\n let+ ctxt, idx = associate_index ctxt ticket in\n (ctxt, `Created, idx)\n\n module Internal_for_tests = struct\n let set_count ctxt count = set ctxt Ticket_count count\n end\n end\n\n module Ticket_ledger = struct\n let get_opt ctxt tidx aidx = get ctxt (Ticket_ledger (tidx, aidx))\n\n let get ctxt tidx aidx =\n let open Syntax in\n let+ res = get_opt ctxt tidx aidx in\n Option.value ~default:Tx_rollup_l2_qty.zero res\n\n let set ctxt tidx aidx = set ctxt (Ticket_ledger (tidx, aidx))\n\n let remove ctxt tidx aidx = remove ctxt (Ticket_ledger (tidx, aidx))\n\n let spend ctxt tidx aidx qty =\n let open Syntax in\n let* src_balance = get ctxt tidx aidx in\n match Tx_rollup_l2_qty.sub src_balance qty with\n | None -> fail Balance_too_low\n | Some remainder when Tx_rollup_l2_qty.(remainder > zero) ->\n set ctxt tidx aidx remainder\n | Some _ -> remove ctxt tidx aidx\n\n let credit ctxt tidx aidx qty =\n let open Syntax in\n let* balance = get ctxt tidx aidx in\n match Tx_rollup_l2_qty.add balance qty with\n | None -> fail Balance_overflow\n | Some new_balance -> set ctxt tidx aidx new_balance\n\n module Internal_for_tests = struct\n let get_opt = get_opt\n end\n end\nend\n" ;
} ;
{ name = "Tx_rollup_l2_batch" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Tx_rollup_l2_context_sig\n\n(** This module introduces the batches of transactions that the\n layer-2 (1) reads from its inboxes (see\n {!Tx_rollup_message_repr.Batch}), and (2) interprets off-chain.\n\n One of the main concerns of the transaction rollups is to provide\n a high-throughput to its participants. That is, transaction\n rollups are expected to be able to process a significant number of\n operations \226\128\156per second.\226\128\157\n\n Putting aside the computational power required by the rollup node,\n the main limit to the throughput of a transaction rollup is the\n number of operations that can fit in a Tezos block. As such, the\n number of bytes that are necessary to store the batches is of key\n importance.\n\n To estimate the theoretical maximum throughput of the transaction\n rollups as a feature, we can use the following methodology:\n\n {ul {li Determine the number of bytes that can be allocated to\n layer-2 batches in a Tezos block, under the hypothesis\n that only layer-2 batch submissions and the\n consensus-related operations are included in said\n block. Ideally, this needs to take into account the\n limitation of the size of a layer-2 batch imposed by the\n layer-1 protocol, and the size of the signature that comes\n with an individual batch.}\n {li Divide this number by the average size of a layer-2\n operation, this gives an estimate of the maximum layer-2\n operations per block.}\n {li Divide again the result by the average time (in seconds)\n between two Tezos blocks; the result is the theoretical\n maximum number of operations per second the transaction\n rollups allow to process.}}\n\n That is, there is three parameters that decide the throughput of\n transaction rollups, and the average size of an operation is the\n only one under the control of the layer-2 implementation.\n Henceforth, both the definitions of types of this module and the\n implementation of their encodings have been carefully crafted in\n order to allow for compact batches. *)\n\n(** Represents the [signer] of an layer-2 operation. This is either a\n BLS public key or a layer-2 address index, whose metadata in turn\n contains a corresponding BLS public. key *)\ntype signer =\n | Bls_pk of Bls.Public_key.t (** A signer identified by a BLS public key. *)\n | L2_addr of Tx_rollup_l2_address.t\n (** A signer identified by a layer-2 address. Each such adress\n is in turn identified with a BLS public key. *)\n\nmodule Signer_indexable : sig\n type nonrec 'state t = ('state, signer) Indexable.t\n\n type nonrec index = signer Indexable.index\n\n type nonrec value = signer Indexable.value\n\n type either = signer Indexable.either\n\n val encoding : either Data_encoding.t\n\n val compare : either -> either -> int\n\n val pp : Format.formatter -> either -> unit\nend\n\n(** {1 Layer-2 Batches Definitions} *)\n\n(** The operations are versioned, to let the possibility to propose\n new features in future iterations of the protocol. *)\n\nmodule V1 : sig\n type 'status operation_content =\n | Withdraw of {\n destination : Signature.Public_key_hash.t;\n ticket_hash : Alpha_context.Ticket_hash.t;\n qty : Tx_rollup_l2_qty.t;\n }\n (** A [Withdraw] removes [qty] of the tickets represented by\n [ticket_hash] from the operation's signer in layer-2, and\n permits [destination] to retrieve those tickets in layer-1\n through a [Tx_rollup_withdraw] operation. *)\n | Transfer of {\n destination : 'status Tx_rollup_l2_address.Indexable.t;\n ticket_hash : 'status Ticket_indexable.t;\n qty : Tx_rollup_l2_qty.t;\n }\n (** A [Transfer] moves [qty] of the tickets represented by\n [ticket_hash] from the operation's signer in layer-2 to\n [destination] in layer-2. *)\n\n type ('signer, 'content) operation = {\n signer : 'signer Signer_indexable.t;\n counter : int64;\n contents : 'content operation_content list;\n }\n\n type ('signer, 'content) transaction = ('signer, 'content) operation list\n\n type signature = Bls.t\n\n type ('signer, 'content) t = {\n contents : ('signer, 'content) transaction list;\n aggregated_signature : signature;\n }\n\n (** [compact ~bits] is a specialized, space-efficient encoding for a\n batch of layer-2 operations, such as the [bits] first bits of\n the first byte of the resulting binary array are used to encode\n small lists of transactions. *)\n val compact :\n bits:int -> (Indexable.unknown, Indexable.unknown) t Data_encoding.Compact.t\n\n (** A specialized, space-efficient encoding for [transaction].\n\n The first byte of the resulting binary array is used to encode\n the size of lists of less than 254 elements. For larger lists,\n the tag is [11111111] and the list is prefixed by its size,\n which consumes eight bytes. *)\n val compact_transaction :\n (Indexable.unknown, Indexable.unknown) transaction Data_encoding.Compact.t\n\n (** A specialized {!compact_transaction} where the signers are indexes only. *)\n val compact_transaction_signer_index :\n (Indexable.index_only, Indexable.unknown) transaction\n Data_encoding.Compact.t\n\n (** The encoding of reference used to sign a transaction. It is\n derived from {!compact_transaction}. *)\n val transaction_encoding :\n (Indexable.unknown, Indexable.unknown) transaction Data_encoding.t\n\n (** A specialized, space-efficient encoding for [operation].\n\n The first byte of the binary output describes precisely the layout\n of the encoded value.\n\n Considering the tag [ooooccss], [ss] describes the format of\n [signer], [cc] of [counter] and [oooo] of [contents].\n\n More precisely, for [signer],\n\n {ul {li [00] means an index fitting on 1 byte.}\n {li [01] means an index fitting on 2 bytes.}\n {li [10] means an index fitting on 4 bytes.}\n {li [11] means a value of type {!Bls.Public_key.t}.}}\n\n The [counter] field follows a similar logic,\n\n {ul {li [00] means an index fitting on 1 byte.}\n {li [01] means an index fitting on 2 bytes.}\n {li [10] means an index fitting on 4 bytes.}\n {li [11] means an integer fitting on 8 bytes.}\n }\n\n Finally, the [contents] field follows this pattern\n\n {ul {li From [0000] to [1110], the tag encodes the size of the\n list of [operation_content], {i e.g.}, [0010] means that\n there is two elements in [contents].}\n {li [1111] means that [contents] is prefixed by its number\n of elements.}\n } *)\n val compact_operation :\n (Indexable.unknown, Indexable.unknown) operation Data_encoding.Compact.t\n\n (** A specialized, space-efficient encoding for [operation_content].\n\n The first byte of the binary output describes precisely the layout\n of the encoded value.\n\n Considering the tag [0qqttddd], [ddd] describes the format of\n [destination], [tt] of [ticket_hash] and [qq] of [qty]. More\n precisely, for [destination],\n\n {ul {li [000] means a layer-1 address.}\n {li [100] means an index for a layer-2 address, fitting on 1 byte.}\n {li [101] means an index for a layer-2 address, fitting on 2 bytes.}\n {li [110] means an index for a layer-2 address, fitting on 4 bytes.}\n {li [111] means a value (of type {!Tx_rollup_l2_address.t},\n that is a layer-2 address.}\n }\n\n The [ticket_hash] is encoded using this logic:\n\n {ul {li [00] means an index for a ticket hash, fitting on 1 byte.}\n {li [01] means an index for a ticket hash, fitting on 2 bytes.}\n {li [10] means an index for a ticket hash, fitting on 4 bytes.}\n {li [11] means a value (of type {!Ticket_hash.t}.}\n }\n\n The [qty] field follows a similar logic,\n\n {ul {li [00] means an integer fitting on 1 byte.}\n {li [01] means an integer fitting on 2 bytes.}\n {li [10] means an integer fitting on 4 bytes.}\n {li [11] means an integer fitting on 8 bytes.}\n }\n\n If used to read, respectively write, a value where the\n the [destination] is a layer-1 address and the ticket_hash is an\n index, which is not allowed by the layer-2 protocol, then a\n\n - [Data_encoding.Binary.Read_error (Exception_raised_in_user_function ...)],\n\n respectively\n\n - [Data_encoding.Binary.Write_error (Exception_raised_in_user_function ...)]\n\n exception is raised.\n *)\n val compact_operation_content :\n Indexable.unknown operation_content Data_encoding.Compact.t\nend\n\n(** {1 Versioning} *)\n\n(** To pave the road towards being able to update the semantics of the\n transaction rollups without having to interfere with the rejection\n mechanism, we preemptively back the notion of semantics versioning\n into the definition of a layer-2 batch. *)\n\ntype ('signer, 'content) t = V1 of ('signer, 'content) V1.t\n\n(** An encoding for [t] that uses a specialized, space-efficient encoding\n for the list of transactions. *)\nval encoding : (Indexable.unknown, Indexable.unknown) t Data_encoding.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxhead-alpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Tx_rollup_l2_context_sig\n\nlet tag_size = `Uint8\n\ntype signer = Bls_pk of Bls.Public_key.t | L2_addr of Tx_rollup_l2_address.t\n\nmodule Signer_indexable = Indexable.Make (struct\n type t = signer\n\n let pp fmt = function\n | Bls_pk _ -> Format.pp_print_string fmt \"<bls_signature>\"\n | L2_addr addr -> Tx_rollup_l2_address.pp fmt addr\n\n let compare x y =\n match (x, y) with\n | Bls_pk pk1, Bls_pk pk2 -> Bls.Public_key.compare pk1 pk2\n | L2_addr addr1, L2_addr addr2 -> Tx_rollup_l2_address.compare addr1 addr2\n | L2_addr _, Bls_pk _ -> -1\n | Bls_pk _, L2_addr _ -> 1\n\n let encoding =\n let open Data_encoding in\n union\n [\n case\n ~title:\"bls_pk\"\n (Tag 0)\n Bls.Public_key.encoding\n (function Bls_pk pk -> Some pk | _ -> None)\n (fun pk -> Bls_pk pk);\n case\n ~title:\"l2_addr\"\n (Tag 1)\n Tx_rollup_l2_address.encoding\n (function L2_addr addr -> Some addr | _ -> None)\n (fun addr -> L2_addr addr);\n ]\nend)\n\nmodule V1 = struct\n type 'status operation_content =\n | Withdraw of {\n destination : Signature.Public_key_hash.t;\n ticket_hash : Alpha_context.Ticket_hash.t;\n qty : Tx_rollup_l2_qty.t;\n }\n | Transfer of {\n destination : 'status Tx_rollup_l2_address.Indexable.t;\n ticket_hash : 'status Ticket_indexable.t;\n qty : Tx_rollup_l2_qty.t;\n }\n\n type ('signer, 'content) operation = {\n signer : 'signer Signer_indexable.t;\n counter : int64;\n contents : 'content operation_content list;\n }\n\n type ('signer, 'content) transaction = ('signer, 'content) operation list\n\n type signature = Bls.t\n\n type ('signer, 'content) t = {\n contents : ('signer, 'content) transaction list;\n aggregated_signature : signature;\n }\n\n (* --- ENCODING ------------------------------------------------------------- *)\n\n (* --- [operation_content] *)\n\n let compact_binary_operation_content =\n let open Data_encoding.Compact in\n union\n [\n case\n ~title:\"withdraw\"\n (obj3\n (req \"destination\" (payload Signature.Public_key_hash.encoding))\n (req \"ticket_hash\" (payload Alpha_context.Ticket_hash.encoding))\n (req \"qty\" Tx_rollup_l2_qty.compact_encoding))\n (function\n | Withdraw {destination; ticket_hash; qty} ->\n Some (destination, ticket_hash, qty)\n | _ -> None)\n (fun (destination, ticket_hash, qty) ->\n Withdraw {destination; ticket_hash; qty});\n case\n ~title:\"transfer\"\n (obj3\n (req\n \"destination\"\n (Indexable.compact Tx_rollup_l2_address.encoding))\n (req \"ticket_hash\" Ticket_indexable.compact)\n (req \"qty\" Tx_rollup_l2_qty.compact_encoding))\n (function\n | Transfer {destination; ticket_hash; qty} ->\n Some (destination, ticket_hash, qty)\n | _ -> None)\n (fun (destination, ticket_hash, qty) ->\n Transfer {destination; ticket_hash; qty});\n ]\n\n let non_tz4_public_key_hash_encoding =\n let open Data_encoding in\n conv_with_guard\n (fun pkh -> pkh)\n (fun (pkh : Signature.public_key_hash) ->\n match pkh with\n | (Ed25519 _ | Secp256k1 _ | P256 _) as pkh -> Ok pkh\n | Bls _ ->\n Error\n \"Withdraw to tz4 address is not supported in the deprecated \\\n encoding.\")\n Signature.Public_key_hash.encoding\n\n (** JSON encoding for [operation_content] which allows to represent\n withdrawals to tz4 accounts. The [deprecated_] variants are kept for\n backward compatibility purpose. *)\n let json_operation_content =\n let open Data_encoding in\n let withdraw_deprecated destination =\n obj3\n (req \"destination\" destination)\n (req \"ticket_hash\" Alpha_context.Ticket_hash.encoding)\n (req \"qty\" (Compact.make ~tag_size Tx_rollup_l2_qty.compact_encoding))\n in\n let withdraw =\n merge_objs\n (obj1 (req \"direction\" (constant \"withdraw\")))\n (withdraw_deprecated Signature.Public_key_hash.encoding)\n in\n let transfer_deprecated =\n obj3\n (req \"destination\" (Indexable.encoding Tx_rollup_l2_address.encoding))\n (req \"ticket_hash\" (Compact.make ~tag_size Ticket_indexable.compact))\n (req \"qty\" (Compact.make ~tag_size Tx_rollup_l2_qty.compact_encoding))\n in\n let transfer =\n merge_objs\n (obj1 (req \"direction\" (constant \"transfer\")))\n transfer_deprecated\n in\n matching\n (function\n | Withdraw {destination; ticket_hash; qty} ->\n matched 0 withdraw ((), (destination, ticket_hash, qty))\n | Transfer {destination; ticket_hash; qty} ->\n matched 1 transfer ((), (destination, ticket_hash, qty)))\n [\n case\n Json_only\n ~title:\"withdraw\"\n withdraw\n (function\n | Withdraw {destination; ticket_hash; qty} ->\n Some ((), (destination, ticket_hash, qty))\n | _ -> None)\n (fun ((), (destination, ticket_hash, qty)) ->\n Withdraw {destination; ticket_hash; qty});\n case\n Json_only\n ~title:\"transfer\"\n transfer\n (function\n | Transfer {destination; ticket_hash; qty} ->\n Some ((), (destination, ticket_hash, qty))\n | _ -> None)\n (fun ((), (destination, ticket_hash, qty)) ->\n Transfer {destination; ticket_hash; qty});\n case\n Json_only\n ~title:\"deprecated_withdraw\"\n (withdraw_deprecated non_tz4_public_key_hash_encoding)\n (function\n | Withdraw {destination; ticket_hash; qty} ->\n Some (destination, ticket_hash, qty)\n | _ -> None)\n (fun (destination, ticket_hash, qty) ->\n Withdraw {destination; ticket_hash; qty});\n case\n Json_only\n ~title:\"deprecated_transfer\"\n transfer_deprecated\n (function\n | Transfer {destination; ticket_hash; qty} ->\n Some (destination, ticket_hash, qty)\n | _ -> None)\n (fun (destination, ticket_hash, qty) ->\n Transfer {destination; ticket_hash; qty});\n ]\n\n let compact_operation_content =\n (* This is equivalent to Data_encoding.Compact.splitted *)\n Data_encoding.Compact.conv\n ~json:json_operation_content\n (fun x -> x)\n (fun x -> x)\n compact_binary_operation_content\n\n let operation_content_encoding =\n Data_encoding.Compact.make ~tag_size compact_operation_content\n\n let compact_operation encoding_signer =\n Data_encoding.Compact.(\n conv\n (fun {signer; counter; contents} -> (signer, counter, contents))\n (fun (signer, counter, contents) -> {signer; counter; contents})\n @@ obj3\n (req \"signer\" encoding_signer)\n (req \"counter\" int64)\n (req \"contents\" @@ list ~bits:4 operation_content_encoding))\n\n let operation_encoding encoding_signer =\n Data_encoding.Compact.(make ~tag_size (compact_operation encoding_signer))\n\n let compact_transaction encoding_signer =\n Data_encoding.Compact.list ~bits:8 (operation_encoding encoding_signer)\n\n let transaction_encoding :\n 'a -> ('b, Indexable.unknown) transaction Data_encoding.t =\n fun encoding_signer ->\n Data_encoding.Compact.(make ~tag_size (compact_transaction encoding_signer))\n\n let compact_signer_index =\n Data_encoding.Compact.(conv Indexable.to_int32 Indexable.index_exn int32)\n\n let compact_signer_either = Signer_indexable.compact\n\n let compact_operation = compact_operation compact_signer_either\n\n let compact_transaction_signer_index =\n compact_transaction compact_signer_index\n\n let compact_transaction = compact_transaction compact_signer_either\n\n let transaction_encoding = transaction_encoding compact_signer_either\n\n let compact ~bits :\n (Indexable.unknown, Indexable.unknown) t Data_encoding.Compact.t =\n Data_encoding.Compact.(\n conv\n (fun {aggregated_signature; contents} ->\n (aggregated_signature, contents))\n (fun (aggregated_signature, contents) ->\n {aggregated_signature; contents})\n @@ obj2\n (req \"aggregated_signature\" @@ payload Bls.encoding)\n (req \"contents\" @@ list ~bits transaction_encoding))\nend\n\ntype ('signer, 'content) t = V1 of ('signer, 'content) V1.t\n\n(** We use two bits for the versioning of the layer-2 batches, which\n leaves six bits in the shared tag of compact encoding. We use\n these six bits to efficiently encode small lists.\n\n To ensure backward compatibility, the value of the label\n [tag_bits] cannot be modified. To have more than 3 versions of the\n encoding, one would have to use the fourth case to wrap a new\n union.\n\n{[\n union\n ~tag_bits:2\n ~inner_bits:6\n [\n case \"V1\" ...;\n case \"V2\" ...;\n case \"V3\" ...;\n case \"V_next\" ...\n (union [ case \"V4\" ... ; ... ]);\n ]\n]} *)\nlet compact =\n Data_encoding.Compact.(\n union\n ~union_tag_bits:2\n ~cases_tag_bits:6\n [\n case\n ~title:\"V1\"\n (V1.compact ~bits:6)\n (function V1 x -> Some x)\n (fun x -> V1 x);\n ])\n\n(** An encoding for [t] that uses a specialized, space-efficient encoding\n for the list of transactions. *)\nlet encoding : (Indexable.unknown, Indexable.unknown) t Data_encoding.t =\n Data_encoding.Compact.make ~tag_size compact\n" ;
} ;
{ name = "Tx_rollup_l2_apply" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxheadalpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\nopen Tx_rollup_l2_context_sig\nopen Tx_rollup_l2_batch\n\n(** This module introduces the interpretation (off-chain) of layer2 operations\n read from its inboxes.\n\n The main concern is now to interpret operations in the layer2 context\n with a high-throughput and process a significant number of operations\n \226\128\156per second.\226\128\157\n\n The operations can be crafted with indexes (see {!Indexable}). It is meant\n to reduce the size of operations, and therefore, increase the number\n of those in a message to the layer2. You will see in this file indexables\n which are yet unknowns (see {!Indexable.unknown}). They can be later on\n modified to indexes only (see {!Indexable.index_only}) when the potential\n values have been replaced by their indexes.\n\n Therefore, we need to have the minimal number of accesses to the context.\n Thus, when a value is read from its index in the context, it *must* be\n done once.\n*)\n\ntype error +=\n | Counter_mismatch of {\n account : Tx_rollup_l2_address.t;\n expected : int64;\n provided : int64;\n }\n | Incorrect_aggregated_signature\n | Unallocated_metadata of int32\n | Multiple_operations_for_signer of Bls.Public_key.t\n | Invalid_transaction_encoding\n | Invalid_batch_encoding\n | Unexpectedly_indexed_ticket\n | Missing_ticket of Ticket_hash.t\n | Unknown_address of Tx_rollup_l2_address.t\n | Invalid_self_transfer\n | Invalid_zero_transfer\n | Maximum_withdraws_per_message_exceeded of {current : int; maximum : int}\n\n(** Applying operations in the layer2 can result in creating indexes\n associated to both the addresses and the ticket hashes. We keep track\n of these creations in order to replace the values by their indexes\n in future operations. *)\ntype indexes = {\n address_indexes :\n (Tx_rollup_l2_address.t * Tx_rollup_l2_address.Indexable.index) list;\n ticket_indexes : (Ticket_hash.t * Ticket_indexable.index) list;\n}\n\nmodule Message_result : sig\n (** A transaction inside a batch can either be a success or a failure.\n\n In the case of a failure, we store the operation's index which failed\n with the reason it failed. *)\n type transaction_result =\n | Transaction_success\n | Transaction_failure of {index : int; reason : error}\n\n (** A deposit can either be a success or a failure. The created indexes\n must are kept only when the deposit is a success. In the other case,\n we return the reason why the deposit failed. *)\n type deposit_result = Deposit_success of indexes | Deposit_failure of error\n\n (** The operations are versioned (see {!Tx_rollup_l2_batch}). Therefore, we\n introduce the operation results for each version. *)\n\n module Batch_V1 : sig\n type t =\n | Batch_result of {\n results :\n ((Indexable.index_only, Indexable.unknown) V1.transaction\n * transaction_result)\n list;\n indexes : indexes;\n }\n end\n\n type message_result =\n | Deposit_result of deposit_result\n | Batch_V1_result of Batch_V1.t\n\n (* In addition to [message_result] the result contains the list of\n withdrawals that result from failing deposits and layer2-to-layer1\n transfers. *)\n type t = message_result * Tx_rollup_withdraw.t list\n\n val encoding : t Data_encoding.t\nend\n\n(** The record of parameters used during the application of messages. *)\ntype parameters = {\n (* Maximum number of allowed L2-to-L1 withdraws per batch *)\n tx_rollup_max_withdrawals_per_batch : int;\n}\n\nmodule Make (Context : CONTEXT) : sig\n open Context\n\n type ctxt = t\n\n (** The operations are versioned (see {!Tx_rollup_l2_batch}),\n so their interpretations are. *)\n\n module Batch_V1 : sig\n open Tx_rollup_l2_batch.V1\n\n (** [apply_batch ctxt parameters batch] interprets the batch\n {!Tx_rollup_l2_batch.V1.t}.\n\n By construction, a failing transaction will not affect the [ctxt]\n and other transactions will still be interpreted.\n That is, this function can only fail because of internals errors.\n Otherwise, the errors that caused the transactions to fail can be\n observed in the result (see {!Message_result.Batch_V1.t}).\n\n The counters are incremented when the operation is part of a transaction\n that is correctly signed and whose every operations have the expected\n counter. In particular, the result of the application is not important\n (i.e. the counters are updated even if the transaction failed).\n\n In addition, the list of withdrawals resulting from each\n layer2-to-layer1 transfer message in the batch is returned.\n *)\n val apply_batch :\n ctxt ->\n parameters ->\n (Indexable.unknown, Indexable.unknown) t ->\n (ctxt * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m\n\n (** [check_signature ctxt batch] asserts that [batch] is correctly signed.\n\n We recall that [batch] may contain indexes, that is integers which\n replace larger values. The [signer] field of the\n {!Tx_rollup_l2_batch.operation} type is concerned. This field is either\n the public key to be used to check the signature, or an index.\n In case of the public key, [check_signature] will check whether or not\n the related {!Tx_rollup_l2_address.t} has already an index assigned,\n and allocate one if not.\n\n Overall, [check_signature] returns the revised context, the list of\n newly allocated indexes, and an updated version of the batches where\n all [signer] field have been replaced by valid indexes.\n\n {b Note:} What a user is expected to sign is the version of the\n operation it sends to the network. This is potentially unsafe,\n because it means the user signs indexes, not addresses nor\n ticket hashes. This poses two threats: Tezos reorganization,\n and malicious provider of indexes. A Tezos reorganization may\n imply that an index allocated to one address in a given branch\n is allocated to another address in another branch. We deal with\n this issue by making the rollup node aware of the Tezos level at\n each time an index is allocated. This allows to implement a RPC that\n can safely tell a client to use either the full value or the index,\n thanks to Tenderbake finality. To prevent the rollup node to lie,\n we will make the rollup node provide Merkle proofs that allows the\n client to verify that the index is correct.\n *)\n val check_signature :\n ctxt ->\n (Indexable.unknown, Indexable.unknown) t ->\n (ctxt * indexes * (Indexable.index_only, Indexable.unknown) t) m\n end\n\n (** [apply_deposit ctxt deposit] credits a quantity of tickets to a layer2\n address in [ctxt].\n\n This function can fail if the [deposit.amount] is not strictly-positive.\n\n If the [deposit] causes an error, then a withdrawal returning\n the funds to the deposit's sender is returned.\n *)\n val apply_deposit :\n ctxt ->\n Tx_rollup_message.deposit ->\n (ctxt * Message_result.deposit_result * Tx_rollup_withdraw.t option) m\n\n (** [apply_message ctxt parameters message] interprets the [message] in the\n [ctxt].\n\n That is,\n\n {ul {li Deposit tickets if the message is a deposit. }\n {li Decodes the batch and interprets it for the\n correct batch version. }}\n\n The function can fail with {!Invalid_batch_encoding} if it's not able\n to decode the batch.\n\n The function can also return errors from subsequent functions,\n see {!apply_deposit} and batch interpretations for various versions.\n\n The list of withdrawals in the message result followed the ordering\n of the contents in the message.\n *)\n val apply_message :\n ctxt -> parameters -> Tx_rollup_message.t -> (ctxt * Message_result.t) m\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxheadalpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\nopen Tx_rollup_l2_context_sig\nopen Tx_rollup_l2_batch\n\ntype error +=\n | Counter_mismatch of {\n account : Tx_rollup_l2_address.t;\n expected : int64;\n provided : int64;\n }\n | Incorrect_aggregated_signature\n | Unallocated_metadata of int32\n | Multiple_operations_for_signer of Bls.Public_key.t\n | Invalid_transaction_encoding\n | Invalid_batch_encoding\n | Unexpectedly_indexed_ticket\n | Missing_ticket of Ticket_hash.t\n | Unknown_address of Tx_rollup_l2_address.t\n | Invalid_self_transfer\n | Invalid_zero_transfer\n | Maximum_withdraws_per_message_exceeded of {current : int; maximum : int}\n\nlet () =\n let open Data_encoding in\n (* Counter mismatch *)\n register_error_kind\n `Branch\n ~id:\"tx_rollup_operation_counter_mismatch\"\n ~title:\"Operation counter mismatch\"\n ~description:\n \"A transaction rollup operation has been submitted with an incorrect \\\n counter\"\n (obj3\n (req \"account\" Tx_rollup_l2_address.encoding)\n (req \"expected\" int64)\n (req \"provided\" int64))\n (function\n | Counter_mismatch {account; expected; provided} ->\n Some (account, expected, provided)\n | _ -> None)\n (fun (account, expected, provided) ->\n Counter_mismatch {account; expected; provided}) ;\n (* Incorrect aggregated signature *)\n register_error_kind\n `Permanent\n ~id:\"tx_rollup_incorrect_aggregated_signature\"\n ~title:\"Incorrect aggregated signature\"\n ~description:\"The aggregated signature is incorrect\"\n empty\n (function Incorrect_aggregated_signature -> Some () | _ -> None)\n (function () -> Incorrect_aggregated_signature) ;\n (* Unallocated metadata *)\n register_error_kind\n `Branch\n ~id:\"tx_rollup_unknown_metadata\"\n ~title:\"Unknown metadata\"\n ~description:\n \"A public key index was provided but the account information for this \\\n index is not present in the context.\"\n (obj1 (req \"idx\" int32))\n (function Unallocated_metadata i -> Some i | _ -> None)\n (function i -> Unallocated_metadata i) ;\n (* Invalid transaction *)\n register_error_kind\n `Permanent\n ~id:\"tx_rollup_invalid_transaction\"\n ~title:\"Invalid transaction\"\n ~description:\n \"The signer signed multiple operations in the same transaction. He must \\\n gather all the contents in a single operation\"\n (obj1 (req \"pk\" Bls.Public_key.encoding))\n (function Multiple_operations_for_signer idx -> Some idx | _ -> None)\n (function idx -> Multiple_operations_for_signer idx) ;\n (* Invalid transaction encoding *)\n register_error_kind\n `Permanent\n ~id:\"tx_rollup_invalid_transaction_encoding\"\n ~title:\"Invalid transaction encoding\"\n ~description:\"The transaction could not be decoded from bytes\"\n empty\n (function Invalid_transaction_encoding -> Some () | _ -> None)\n (function () -> Invalid_transaction_encoding) ;\n (* Invalid batch encoding *)\n register_error_kind\n `Permanent\n ~id:\"tx_rollup_invalid_batch_encoding\"\n ~title:\"Invalid batch encoding\"\n ~description:\"The batch could not be decoded from bytes\"\n empty\n (function Invalid_batch_encoding -> Some () | _ -> None)\n (function () -> Invalid_batch_encoding) ;\n (* Unexpectedly indexed ticket *)\n register_error_kind\n `Permanent\n ~id:\"tx_rollup_unexpectedly_indexed_ticket\"\n ~title:\"Unexpected indexed ticket in deposit or transfer\"\n ~description:\n \"Tickets in layer2-to-layer1 transfers must be referenced by value.\"\n empty\n (function Unexpectedly_indexed_ticket -> Some () | _ -> None)\n (function () -> Unexpectedly_indexed_ticket) ;\n (* Missing ticket *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_missing_ticket\"\n ~title:\"Attempted to withdraw from a ticket missing in the rollup\"\n ~description:\n \"A withdrawal must reference a ticket that already exists in the rollup.\"\n (obj1 (req \"ticket_hash\" Ticket_hash.encoding))\n (function Missing_ticket ticket_hash -> Some ticket_hash | _ -> None)\n (function ticket_hash -> Missing_ticket ticket_hash) ;\n (* Unknown address *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_unknown_address\"\n ~title:\"Attempted to sign a transfer with an unknown address\"\n ~description:\n \"The address must exist in the context when signing a transfer with it.\"\n (obj1 (req \"address\" Tx_rollup_l2_address.encoding))\n (function Unknown_address addr -> Some addr | _ -> None)\n (function addr -> Unknown_address addr) ;\n (* Invalid self transfer *)\n register_error_kind\n `Temporary\n ~id:\"tx_rollup_invalid_self_transfer\"\n ~title:\"Attempted to transfer ticket to self\"\n ~description:\"The index for the destination is the same as the sender\"\n empty\n (function Invalid_self_transfer -> Some () | _ -> None)\n (function () -> Invalid_self_transfer) ;\n (* Invalid zero transfer *)\n register_error_kind\n `Permanent\n ~id:\"tx_rollup_invalid_zero_transfer\"\n ~title:\"Attempted to transfer zero ticket\"\n ~description:\"A transfer's amount must be greater than zero.\"\n empty\n (function Invalid_zero_transfer -> Some () | _ -> None)\n (function () -> Invalid_zero_transfer) ;\n (* Maximum_withdraws_per_message_exceeded *)\n register_error_kind\n `Permanent\n ~id:\"tx_rollup_maximum_withdraws_per_message_exceeded\"\n ~title:\"Maximum tx-rollup withdraws per message exceeded\"\n ~description:\n \"The maximum number of withdraws allowed per tx-rollup message exceeded\"\n (obj2 (req \"current\" int31) (req \"limit\" int31))\n (function\n | Maximum_withdraws_per_message_exceeded {current; maximum} ->\n Some (current, maximum)\n | _ -> None)\n (fun (current, maximum) ->\n Maximum_withdraws_per_message_exceeded {current; maximum})\n\ntype indexes = {\n address_indexes :\n (Tx_rollup_l2_address.t * Tx_rollup_l2_address.Indexable.index) list;\n ticket_indexes : (Ticket_hash.t * Ticket_indexable.index) list;\n}\n\nlet encoding_indexes : indexes Data_encoding.t =\n let open Data_encoding in\n conv\n (fun {address_indexes; ticket_indexes} -> (address_indexes, ticket_indexes))\n (fun (address_indexes, ticket_indexes) -> {address_indexes; ticket_indexes})\n @@ obj2\n (req\n \"address_indexes\"\n (list\n (tup2\n Tx_rollup_l2_address.encoding\n Tx_rollup_l2_address.Indexable.index_encoding)))\n (req\n \"ticket_indexes\"\n (list (tup2 Ticket_hash.encoding Ticket_indexable.index_encoding)))\n\nmodule Message_result = struct\n type transaction_result =\n | Transaction_success\n | Transaction_failure of {index : int; reason : error}\n\n type deposit_result = Deposit_success of indexes | Deposit_failure of error\n\n let encoding_transaction_result =\n let open Data_encoding in\n union\n [\n (let kind = \"transaction_success\" in\n case\n ~title:kind\n (Tag 0)\n (constant kind)\n (function Transaction_success -> Some () | _ -> None)\n (fun () -> Transaction_success));\n (let kind = \"transaction_failure\" in\n case\n ~title:kind\n (Tag 1)\n (obj1\n (req\n kind\n (obj2\n (req \"transaction_index\" Data_encoding.int31)\n (req \"reason\" Error_monad.error_encoding))))\n (function\n | Transaction_failure {index; reason} -> Some (index, reason)\n | _ -> None)\n (fun (index, reason) -> Transaction_failure {index; reason}));\n ]\n\n let encoding_deposit_result =\n let open Data_encoding in\n union\n [\n (let kind = \"deposit_success\" in\n case\n ~title:kind\n (Tag 0)\n (obj1 (req kind encoding_indexes))\n (function Deposit_success indexes -> Some indexes | _ -> None)\n (fun indexes -> Deposit_success indexes));\n (let kind = \"deposit_failure\" in\n case\n ~title:kind\n (Tag 1)\n (obj1 (req kind (obj1 (req \"reason\" Error_monad.error_encoding))))\n (function Deposit_failure reason -> Some reason | _ -> None)\n (fun reason -> Deposit_failure reason));\n ]\n\n module Batch_V1 = struct\n type t =\n | Batch_result of {\n results :\n ((Indexable.index_only, Indexable.unknown) V1.transaction\n * transaction_result)\n list;\n indexes : indexes;\n }\n\n let encoding =\n let open Data_encoding in\n conv\n (fun (Batch_result {results; indexes}) -> (results, indexes))\n (fun (results, indexes) -> Batch_result {results; indexes})\n (obj2\n (req \"results\"\n @@ list\n (Data_encoding.tup2\n (Compact.make\n ~tag_size:`Uint8\n V1.compact_transaction_signer_index)\n encoding_transaction_result))\n (req \"allocated_indexes\" encoding_indexes))\n end\n\n type message_result =\n | Deposit_result of deposit_result\n | Batch_V1_result of Batch_V1.t\n\n let message_result_encoding =\n let open Data_encoding in\n union\n [\n (let kind = \"deposit_result\" in\n case\n ~title:kind\n (Tag 0)\n (obj1 (req kind encoding_deposit_result))\n (function Deposit_result result -> Some result | _ -> None)\n (fun result -> Deposit_result result));\n (let kind = \"batch_v1_result\" in\n case\n ~title:kind\n (Tag 1)\n (obj1 (req kind Batch_V1.encoding))\n (function Batch_V1_result result -> Some result | _ -> None)\n (fun result -> Batch_V1_result result));\n ]\n\n type t = message_result * Tx_rollup_withdraw.t list\n\n let encoding =\n Data_encoding.(\n tup2 message_result_encoding (list Tx_rollup_withdraw.encoding))\nend\n\ntype parameters = {\n (* Maximum number of allowed L2-to-L1 withdraws per batch *)\n tx_rollup_max_withdrawals_per_batch : int;\n}\n\nmodule Make (Context : CONTEXT) = struct\n open Context\n open Syntax\n open Message_result\n\n type ctxt = Context.t\n\n (** {3. Indexes. } *)\n\n (** The application of a message can (and is supposed to) use and\n create several indexes during the application of a {Tx_rollup_message.t}.\n *)\n\n let index get_or_associate_index add_index ctxt indexes indexable =\n let open Indexable in\n match destruct indexable with\n | Right v -> (\n let+ ctxt, created, idx = get_or_associate_index ctxt v in\n match created with\n | `Existed -> (ctxt, indexes, idx)\n | `Created -> (ctxt, add_index indexes (v, idx), idx))\n | Left i -> return (ctxt, indexes, i)\n\n let address_index ctxt indexes indexable =\n let get_or_associate_index = Address_index.get_or_associate_index in\n let add_index indexes x =\n {indexes with address_indexes = x :: indexes.address_indexes}\n in\n index get_or_associate_index add_index ctxt indexes indexable\n\n let ticket_index ctxt indexes indexable =\n let get_or_associate_index = Ticket_index.get_or_associate_index in\n let add_index indexes x =\n {indexes with ticket_indexes = x :: indexes.ticket_indexes}\n in\n index get_or_associate_index add_index ctxt indexes indexable\n\n let address_of_signer_index :\n Signer_indexable.index -> Tx_rollup_l2_address.Indexable.index =\n fun idx -> Indexable.(index_exn (to_int32 idx))\n\n let signer_of_address_index :\n Tx_rollup_l2_address.Indexable.index -> Signer_indexable.index =\n fun idx -> Indexable.(index_exn (to_int32 idx))\n\n let empty_indexes = {address_indexes = []; ticket_indexes = []}\n\n let assert_non_zero_quantity qty =\n fail_when Tx_rollup_l2_qty.(qty = zero) Invalid_zero_transfer\n\n (** {2. Counter } *)\n\n (** [get_metadata ctxt idx] returns the metadata associated to [idx] in\n [ctxt]. It must have an associated metadata in the context, otherwise,\n something went wrong in {!check_signature}. *)\n let get_metadata : ctxt -> address_index -> metadata m =\n fun ctxt idx ->\n let open Address_metadata in\n let* metadata = get ctxt idx in\n match metadata with\n | None -> fail (Unallocated_metadata (Indexable.to_int32 idx))\n | Some metadata -> return metadata\n\n (** [get_metadata_signer] gets the metadata for a signer using {!get_metadata}.\n It transforms a signer index to an address one. *)\n let get_metadata_signer : ctxt -> Signer_indexable.index -> metadata m =\n fun ctxt signer_idx -> get_metadata ctxt (address_of_signer_index signer_idx)\n\n (** [transfers ctxt source_idx destination_idx tidx amount] transfers [amount]\n from [source_idx] to [destination_idx] of [tidx]. *)\n let transfer ctxt source_idx destination_idx tidx amount =\n let* () =\n fail_unless\n Compare.Int.(Indexable.compare_indexes source_idx destination_idx <> 0)\n Invalid_self_transfer\n in\n let* () = assert_non_zero_quantity amount in\n let* ctxt = Ticket_ledger.spend ctxt tidx source_idx amount in\n Ticket_ledger.credit ctxt tidx destination_idx amount\n\n (** [deposit ctxt aidx tidx amount] credits [amount] of [tidx] to [aidx].\n They are deposited from the layer1 and created in the layer2 context, but,\n we only handle the creation part (i.e. in the layer2) in this module. *)\n let deposit ctxt aidx tidx amount = Ticket_ledger.credit ctxt tidx aidx amount\n\n module Batch_V1 = struct\n open Tx_rollup_l2_batch.V1\n\n (** [operation_with_signer_index ctxt indexes op] takes an operation\n and performs multiple get/sets on the context to return an operation\n where the signer is replaced by its index.\n\n It performs on the [ctxt]:\n {ul {li If the signer is an index, we read the public key from the\n [ctxt].}\n {li If the signer is a public key, we associate a new index to\n it in the [ctxt]. The public key is also added to the metadata\n if not already present.}}\n\n {b Note:} If the context already contains all the required information,\n we only read from it. *)\n let operation_with_signer_index :\n ctxt ->\n indexes ->\n ('signer, 'content) operation ->\n (ctxt\n * indexes\n * (Indexable.index_only, 'content) operation\n * Bls.Public_key.t)\n m =\n fun ctxt indexes op ->\n let* ctxt, indexes, pk, idx =\n match Indexable.destruct op.signer with\n | Left signer_index ->\n (* Get the public key from the index. *)\n let address_index = address_of_signer_index signer_index in\n let* metadata = get_metadata ctxt address_index in\n let pk = metadata.public_key in\n return (ctxt, indexes, pk, address_index)\n | Right (Bls_pk signer_pk) -> (\n (* Initialize the ctxt with public_key if it's necessary. *)\n let addr = Bls.Public_key.hash signer_pk in\n let* ctxt, created, idx =\n Address_index.get_or_associate_index ctxt addr\n in\n\n (* If the address is created, we add it to [indexes]. *)\n match created with\n | `Existed ->\n (* If the public key existed in the context, it should not\n be added in [indexes]. However, the metadata might not\n have been initialized for the public key. Especially during\n a deposit, the deposit destination is a layer2 address and\n it contains no information about the public key.\n *)\n let* ctxt =\n let* metadata = Address_metadata.get ctxt idx in\n match metadata with\n | Some _ ->\n (* If the metadata exists, then the public key necessarily\n exists, we do not need to change the context. *)\n return ctxt\n | None ->\n Address_metadata.init_with_public_key ctxt idx signer_pk\n in\n return (ctxt, indexes, signer_pk, idx)\n | `Created ->\n (* If the index is created, we need to add to indexes and\n initialize the metadata. *)\n let indexes =\n {\n indexes with\n address_indexes = (addr, idx) :: indexes.address_indexes;\n }\n in\n let* ctxt =\n Address_metadata.init_with_public_key ctxt idx signer_pk\n in\n return (ctxt, indexes, signer_pk, idx))\n | Right (L2_addr signer_addr) -> (\n (* In order to get the public key associated to [signer_addr], there\n needs to be both an index associated to it, and a metadata for this\n index. *)\n let* idx = Address_index.get ctxt signer_addr in\n match idx with\n | None -> fail (Unknown_address signer_addr)\n | Some idx ->\n let* metadata = get_metadata ctxt idx in\n return (ctxt, indexes, metadata.public_key, idx))\n in\n let op : (Indexable.index_only, 'content) operation =\n {op with signer = signer_of_address_index idx}\n in\n return (ctxt, indexes, op, pk)\n\n (** [check_transaction ctxt indexes transmitted transaction] performs an\n *active* check of an operation.\n We consider this as an *active* check because the function is likely to\n write in the [ctxt], since it replaces the signer's public key\n (if provided) by its index in {!operation_with_signer_index}.\n\n Outside of the active preprocessing, we check that a signer signs\n at most one operation in the [transaction].\n\n It also associates the signer to the bytes representation of a\n transaction in [transmitted], which is used to check the aggregated\n signature.\n *)\n let check_transaction ctxt indexes transmitted transaction =\n let* buf =\n match\n Data_encoding.Binary.to_bytes_opt\n (Data_encoding.Compact.make ~tag_size:`Uint8 compact_transaction)\n transaction\n with\n | Some buf -> return buf\n | None -> fail Invalid_transaction_encoding\n in\n let* ctxt, indexes, transmitted, _, rev_ops =\n list_fold_left_m\n (fun (ctxt, indexes, transmitted, signers, ops) op ->\n let* ctxt, indexes, op, pk =\n operation_with_signer_index ctxt indexes op\n in\n if List.mem ~equal:Bls.Public_key.equal pk signers then\n fail (Multiple_operations_for_signer pk)\n else\n return\n ( ctxt,\n indexes,\n (pk, buf) :: transmitted,\n pk :: signers,\n op :: ops ))\n (ctxt, indexes, transmitted, [], [])\n transaction\n in\n return (ctxt, indexes, transmitted, List.rev rev_ops)\n\n let check_signature :\n ctxt ->\n ('signer, 'content) t ->\n (ctxt * indexes * (Indexable.index_only, 'content) t) m =\n fun ctxt ({contents = transactions; aggregated_signature} as batch) ->\n let* ctxt, indexes, transmitted, rev_new_transactions =\n list_fold_left_m\n (fun (ctxt, indexes, transmitted, new_transactions) transaction ->\n (* To check the signature, we need the list of [buf] each signer\n signed. That is, the [buf] is the binary encoding of the\n [transaction]. *)\n let* ctxt, indexes, transmitted, transaction =\n check_transaction ctxt indexes transmitted transaction\n in\n return (ctxt, indexes, transmitted, transaction :: new_transactions))\n (ctxt, empty_indexes, [], [])\n transactions\n in\n (* Once we collected the public keys for each signer and the buffers\n they signed, we can check the signature. *)\n let* b = bls_verify transmitted aggregated_signature in\n let* () = fail_unless b Incorrect_aggregated_signature in\n let batch = {batch with contents = List.rev rev_new_transactions} in\n return (ctxt, indexes, batch)\n\n (** {2. Apply } *)\n\n (** [apply_operation_content ctxt source content] performs the transfer\n on the [ctxt]. The validity of the transfer is checked in\n the context itself, e.g. for an invalid balance.\n\n It returns the potential created indexes:\n\n {ul {li The destination address index.}\n {li The ticket exchanged index.}}\n *)\n let apply_operation_content :\n ctxt ->\n indexes ->\n Signer_indexable.index ->\n 'content operation_content ->\n (ctxt * indexes * Tx_rollup_withdraw.t option) m =\n fun ctxt indexes source_idx op_content ->\n match op_content with\n | Withdraw {destination = claimer; ticket_hash; qty = amount} ->\n (* To withdraw, the ticket must already exist in the\n rollup and be indexed (the ticket must have already been\n assigned an index in the content: otherwise the ticket has\n not been seen before and we can't withdraw from it). *)\n let* tidx_opt = Ticket_index.get ctxt ticket_hash in\n let*? tidx =\n Option.value_e ~error:(Missing_ticket ticket_hash) tidx_opt\n in\n let source_idx = address_of_signer_index source_idx in\n\n (* spend the ticket -- this is responsible for checking that\n the source has the required balance *)\n let* () = assert_non_zero_quantity amount in\n let* ctxt = Ticket_ledger.spend ctxt tidx source_idx amount in\n let withdrawal = Tx_rollup_withdraw.{claimer; ticket_hash; amount} in\n return (ctxt, indexes, Some withdrawal)\n | Transfer {destination; ticket_hash; qty} ->\n let* ctxt, indexes, dest_idx =\n address_index ctxt indexes destination\n in\n let* ctxt, indexes, tidx = ticket_index ctxt indexes ticket_hash in\n let source_idx = address_of_signer_index source_idx in\n let* ctxt = transfer ctxt source_idx dest_idx tidx qty in\n return (ctxt, indexes, None)\n\n (** [check_counter ctxt signer counter] asserts that the provided [counter] is the\n successor of the one associated to the [signer] in the [ctxt]. *)\n let check_counter :\n ctxt -> Indexable.index_only Signer_indexable.t -> int64 -> unit m =\n fun ctxt signer counter ->\n let* metadata = get_metadata_signer ctxt signer in\n fail_unless\n Compare.Int64.(counter = Int64.succ metadata.counter)\n (Counter_mismatch\n {\n account = Bls.Public_key.hash metadata.public_key;\n expected = Int64.succ metadata.counter;\n provided = counter;\n })\n\n (** [apply_operation ctxt indexes op] checks the counter validity for the [op.signer] with\n {!check_counter}, and then calls {!apply_operation_content} for each content in [op]. *)\n let apply_operation :\n ctxt ->\n indexes ->\n (Indexable.index_only, Indexable.unknown) operation ->\n (ctxt * indexes * Tx_rollup_withdraw.t list) m =\n fun ctxt indexes {signer; counter; contents} ->\n (* Before applying any operation, we check the counter *)\n let* () = check_counter ctxt signer counter in\n let* ctxt, indexes, rev_withdrawals =\n list_fold_left_m\n (fun (ctxt, indexes, withdrawals) content ->\n let* ctxt, indexes, withdrawal_opt =\n apply_operation_content ctxt indexes signer content\n in\n return (ctxt, indexes, Option.to_list withdrawal_opt @ withdrawals))\n (ctxt, indexes, [])\n contents\n in\n return (ctxt, indexes, rev_withdrawals |> List.rev)\n\n (** [apply_transaction ctxt indexes transaction] applies each operation in\n the [transaction]. It returns a {!transaction_result}, i.e. either\n every operation in the [transaction] succedeed and the [ctxt] is\n modified, or the [transaction] is a failure and the context\n is left untouched.\n *)\n let apply_transaction :\n ctxt ->\n indexes ->\n (Indexable.index_only, Indexable.unknown) transaction ->\n (ctxt * indexes * transaction_result * Tx_rollup_withdraw.t list) m =\n fun initial_ctxt initial_indexes transaction ->\n let rec fold (ctxt, prev_indexes, withdrawals) index ops =\n match ops with\n | [] -> return (ctxt, prev_indexes, Transaction_success, withdrawals)\n | op :: rst ->\n let* ctxt, indexes, status, withdrawals =\n catch\n (apply_operation ctxt prev_indexes op)\n (fun (ctxt, indexes, op_withdrawals) ->\n fold\n (ctxt, indexes, withdrawals @ op_withdrawals)\n (index + 1)\n rst)\n (fun reason ->\n return\n ( initial_ctxt,\n initial_indexes,\n Transaction_failure {index; reason},\n [] ))\n in\n return (ctxt, indexes, status, withdrawals)\n in\n fold (initial_ctxt, initial_indexes, []) 0 transaction\n\n (** [update_counters ctxt status transaction] updates the counters for\n the signers of operations in [transaction]. If the [transaction]\n failed because of a [Counter_mismatch] the counters are left\n untouched.\n *)\n let update_counters ctxt status transaction =\n match status with\n | Transaction_failure {reason = Counter_mismatch _; _} -> return ctxt\n | Transaction_failure _ | Transaction_success ->\n list_fold_left_m\n (fun ctxt (op : (Indexable.index_only, _) operation) ->\n Address_metadata.incr_counter ctxt\n @@ address_of_signer_index op.signer)\n ctxt\n transaction\n\n let apply_batch :\n ctxt ->\n parameters ->\n (Indexable.unknown, Indexable.unknown) t ->\n (ctxt * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m =\n fun ctxt parameters batch ->\n let* ctxt, indexes, batch = check_signature ctxt batch in\n let {contents; _} = batch in\n let* ctxt, indexes, rev_results, withdrawals =\n list_fold_left_m\n (fun (prev_ctxt, prev_indexes, results, withdrawals) transaction ->\n let* new_ctxt, new_indexes, status, transaction_withdrawals =\n apply_transaction prev_ctxt prev_indexes transaction\n in\n let* new_ctxt = update_counters new_ctxt status transaction in\n return\n ( new_ctxt,\n new_indexes,\n (transaction, status) :: results,\n withdrawals @ transaction_withdrawals ))\n (ctxt, indexes, [], [])\n contents\n in\n let limit = parameters.tx_rollup_max_withdrawals_per_batch in\n if Compare.List_length_with.(withdrawals > limit) then\n fail\n (Maximum_withdraws_per_message_exceeded\n {current = List.length withdrawals; maximum = limit})\n else\n let results = List.rev rev_results in\n return\n ( ctxt,\n Message_result.Batch_V1.Batch_result {results; indexes},\n withdrawals )\n end\n\n let apply_deposit :\n ctxt ->\n Tx_rollup_message.deposit ->\n (ctxt * deposit_result * Tx_rollup_withdraw.t option) m =\n fun initial_ctxt Tx_rollup_message.{sender; destination; ticket_hash; amount} ->\n let apply_deposit () =\n let* ctxt, indexes, aidx =\n address_index initial_ctxt empty_indexes destination\n in\n let* ctxt, indexes, tidx =\n ticket_index ctxt indexes Indexable.(value ticket_hash)\n in\n let* ctxt = deposit ctxt aidx tidx amount in\n return (ctxt, indexes)\n in\n catch\n (apply_deposit ())\n (fun (ctxt, indexes) -> return (ctxt, Deposit_success indexes, None))\n (fun reason ->\n (* Should there be an error during the deposit, then return\n the full [amount] to [sender] in the form of a\n withdrawal. *)\n let withdrawal =\n Tx_rollup_withdraw.{claimer = sender; ticket_hash; amount}\n in\n return (initial_ctxt, Deposit_failure reason, Some withdrawal))\n\n let apply_message :\n ctxt -> parameters -> Tx_rollup_message.t -> (ctxt * Message_result.t) m =\n fun ctxt parameters msg ->\n let open Tx_rollup_message in\n match msg with\n | Deposit deposit ->\n let* ctxt, result, withdrawl_opt = apply_deposit ctxt deposit in\n return (ctxt, (Deposit_result result, Option.to_list withdrawl_opt))\n | Batch str -> (\n let batch =\n Data_encoding.Binary.of_string_opt Tx_rollup_l2_batch.encoding str\n in\n match batch with\n | Some (V1 batch) ->\n let* ctxt, result, withdrawals =\n Batch_V1.apply_batch ctxt parameters batch\n in\n return (ctxt, (Batch_V1_result result, withdrawals))\n | None -> fail Invalid_batch_encoding)\nend\n" ;
} ;
{ name = "Tx_rollup_l2_verifier" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxheadalpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\nmodule Verifier_storage : sig\n include\n Tx_rollup_l2_storage_sig.STORAGE\n with type t = Context.tree\n and type 'a m = ('a, error) result Lwt.t\nend\n\nmodule Verifier_context : sig\n include Tx_rollup_l2_context_sig.CONTEXT with type t = Verifier_storage.t\nend\n\n(** [verify_proof ctxt message proof ~proof_length ~agreed ~rejected ~max_proof_size]\n verifies a Merkle proof for a L2 message, starting from the state\n [agreed]. If the [proof] is correct, and the final Merkle hash is\n not equal to [rejected], then [verify_proof] passes.\n\n Note that if [proof_length] is larger than [max_proof_size] and the final\n Merkle hash is equal to [rejected], the needed proof for the rejected\n commitment is too large, thus, [verify_proof] passes and the commitment\n is rejected. *)\nval verify_proof :\n Alpha_context.t ->\n Tx_rollup_l2_apply.parameters ->\n Tx_rollup_message.t ->\n Tx_rollup_l2_proof.t ->\n proof_length:int ->\n agreed:Tx_rollup_message_result.t ->\n rejected:Tx_rollup_message_result_hash.t ->\n max_proof_size:int ->\n Alpha_context.t tzresult Lwt.t\n\n(**/**)\n\nmodule Internal_for_tests : sig\n val verify_l2_proof :\n Context.Proof.stream Context.Proof.t ->\n Tx_rollup_l2_apply.parameters ->\n Tx_rollup_message.t ->\n ( Context.tree * Tx_rollup_withdraw.order list,\n [ `Proof_mismatch of string\n | `Stream_too_long of string\n | `Stream_too_short of string ] )\n result\n Lwt.t\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxheadalpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Tx_rollup_errors_repr\nopen Alpha_context\n\n(* {{Note}} This model should be part of [Tx_rollup_gas].\n Unfortunately, this is not possible, because this module is defined\n on top of [Alpha_context], while [Tx_rollup_gas] is defined on top\n of [Raw_context]. *)\n\nlet verify_proof_model message_size proof_size =\n let open Saturation_repr in\n (* The cost of verifiying the proof depends bilinearly on the size\n of the message (that is expected to capture the algoritmic\n complexity of computation to make) and the size of the proof\n (that is expected to capture the overhead of the storage). *)\n let proof_size_coeff = safe_int 124 in\n let message_size_coeff = safe_int 8_416 in\n\n let ( * ) = mul in\n let ( + ) = add in\n\n (proof_size_coeff * safe_int proof_size)\n + (message_size_coeff * safe_int message_size)\n\nlet consume_verify_proof_cost ctxt ~message_size ~proof_size =\n let max_proof_size =\n Alpha_context.Constants.tx_rollup_rejection_max_proof_size ctxt\n in\n (* We are interested in having a safe over-approximation of the\n overhead of the proof interpretation. We have trained the model\n on data coming from contexts of various \226\128\156size\226\128\157 (i.e., number of\n leafs), but there is an edge case when it comes to proof\n verification that is hard to consider correctly: when the context\n is empty, the size is ridiculously small, no matter how many\n transactions are executed.\n\n As a safety net, we systematically compute a gas cost as if the\n proof is at least the big enough to declare the message as\n invalid (using the [tx_rollup_rejection_max_proof_size]\n parametric constant). *)\n Gas.consume ctxt\n @@ verify_proof_model message_size (Compare.Int.max proof_size max_proof_size)\n\nmodule Verifier_storage :\n Tx_rollup_l2_storage_sig.STORAGE\n with type t = Context.tree\n and type 'a m = ('a, error) result Lwt.t = struct\n type t = Context.tree\n\n type 'a m = ('a, error) result Lwt.t\n\n module Syntax = struct\n let ( let* ) = ( >>=? )\n\n let ( let+ ) = ( >|=? )\n\n let return = return\n\n let fail e = Lwt.return (Error e)\n\n let catch (m : 'a m) k h = m >>= function Ok x -> k x | Error e -> h e\n\n let list_fold_left_m = List.fold_left_es\n end\n\n let path k = [Bytes.to_string k]\n\n let get store key = Context.Tree.find store (path key) >>= return\n\n let set store key value = Context.Tree.add store (path key) value >>= return\n\n let remove store key = Context.Tree.remove store (path key) >>= return\nend\n\nmodule Verifier_context = Tx_rollup_l2_context.Make (Verifier_storage)\nmodule Verifier_apply = Tx_rollup_l2_apply.Make (Verifier_context)\n\nlet hash_message_result ctxt after withdraw =\n Tx_rollup_hash.message_result\n ctxt\n {context_hash = after; withdraw_list_hash = withdraw}\n\n(** [after_hash_when_proof_failed before] produces the\n {!Alpha_context.Tx_rollup_message_result_hash} expected if a proof failed.\n That is, the after hash is the same as [before] and it produced zero\n withdrawals. *)\nlet after_hash_when_proof_failed ctxt before =\n hash_message_result ctxt before Tx_rollup_withdraw_list_hash.empty\n\nlet verify_l2_proof proof parameters message =\n Context.verify_stream_proof proof (fun tree ->\n Verifier_apply.apply_message tree parameters message >>= function\n | Ok (tree, (_, withdrawals)) -> Lwt.return (tree, withdrawals)\n | Error _ -> Lwt.return (tree, []))\n\n(** [compute_proof_after_hash ~max_proof_size agreed proof message] computes the\n after hash expected while verifying [proof] on [message] starting from\n [agreed].\n\n Note that if the proof is incorrect this function fails and the commit\n can not be rejected. *)\nlet compute_proof_after_hash ~proof_length ~max_proof_size ctxt parameters\n agreed (proof : Tx_rollup_l2_proof.t) message =\n let message_length =\n Data_encoding.Binary.length Tx_rollup_message.encoding message\n in\n (* When considering \226\128\156proof large enough to make a batch invalid,\n even if truncated\226\128\157, we actually need to take into consideration\n the size of the message.\n\n [max_proof_size] is the upper bound, but we need to make room for\n the message itself. So the real limit for the proof size is\n reduced to that end. This way, we save a bit of TPS compared to\n just having a lower [max_proof_size] constant. *)\n let max_proof_size = max_proof_size - message_length in\n let proof_is_too_long = Compare.Int.(proof_length > max_proof_size) in\n let before = match proof.before with `Node x -> x | `Value x -> x in\n let agreed_is_correct = Context_hash.(before = agreed) in\n fail_unless\n agreed_is_correct\n (Proof_invalid_before {provided = before; agreed})\n >>=? fun () ->\n consume_verify_proof_cost\n ctxt\n ~message_size:message_length\n ~proof_size:proof_length\n >>?= fun ctxt ->\n verify_l2_proof proof parameters message >>= fun res ->\n match res with\n | (Ok _ | Error (`Stream_too_short _)) when proof_is_too_long ->\n (* If the proof is larger than [max_proof_size] we care about 2 cases:\n\n - The proof verification succedeed but should not be considered valid\n since it is larger than the size limit\n - The proof verification failed because it was truncated but was\n already larger than the size limit\n\n In those two cases, the expected after hash is\n [after_hash_when_proof_failed] because the correct commitment is\n \"we were not able to apply this message, so after is the same\n as before\"\n *)\n after_hash_when_proof_failed ctxt agreed >>?= fun res -> return res\n | Ok (tree, withdrawals) ->\n (* The proof is small enough, we compare the computed hash with the\n committed one *)\n let tree_hash = Context.Tree.hash tree in\n Tx_rollup_hash.withdraw_list ctxt withdrawals\n >>?= fun (ctxt, withdrawals) ->\n hash_message_result ctxt tree_hash withdrawals >>?= fun res -> return res\n | Error _ ->\n (* Finally, the proof verification leads to an internal Irmin error *)\n tzfail Proof_failed_to_reject\n\nlet verify_proof ctxt parameters message proof ~proof_length\n ~(agreed : Tx_rollup_message_result.t) ~rejected ~max_proof_size =\n compute_proof_after_hash\n ctxt\n parameters\n agreed.context_hash\n ~proof_length\n ~max_proof_size\n proof\n message\n >>=? fun (ctxt, computed_result) ->\n if Alpha_context.Tx_rollup_message_result_hash.(computed_result <> rejected)\n then return ctxt\n else tzfail Proof_produced_rejected_state\n\nmodule Internal_for_tests = struct\n let verify_l2_proof = verify_l2_proof\nend\n" ;
} ;
{ name = "Local_gas_counter" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module exposes an API for local gas counting. It provides a set of\n functions for updating a gas counter without applying it on an\n an [Alpha_context.context]. *)\n\n(** A [local_gas_counter] is a wrapped [int]. *)\ntype local_gas_counter = Local_gas_counter of int [@@ocaml.unboxed]\n\n(** A type for describing a context that is not up to date with respect to gas\n consumption. *)\ntype outdated_context\n\n(*** [update_context gas_counter outdated_ctxt] returns a regular context,\n extracted from [outdated_ctxt] with [gas_counter] applied. *)\nval update_context :\n local_gas_counter -> outdated_context -> Alpha_context.context\n\n(** [local_gas_counter_and_outdated_context ctxt] returns the gas counter value\n corresponding to the remaining gas in the given context [ctxt] along with\n an [outdated_context] value. *)\nval local_gas_counter_and_outdated_context :\n Alpha_context.context -> local_gas_counter * outdated_context\n\n(** [use_gas_counter_in_context outdated_ctxt gas_counter f] first applies the\n [gas_counter] on the outdated context [outdated_ctxt], then invokes [f] on\n the resulting context, and returns a new [outdated_context] and a\n [local_gas_counter] value. *)\nval use_gas_counter_in_context :\n outdated_context ->\n local_gas_counter ->\n (Alpha_context.context -> ('a * Alpha_context.context) tzresult Lwt.t) ->\n ('a * outdated_context * local_gas_counter) tzresult Lwt.t\n\n(** [consume_opt amt cost] attempts to consume an [amt] of gas and returns the\n new remaining value wrapped in [Some]. If the resulting gas is negative\n [None] is returned. *)\nval consume_opt :\n local_gas_counter -> Alpha_context.Gas.cost -> local_gas_counter option\n\n(** [consume amt cost] attempts to consume an [amt] of gas and returns the\n new remaining value as a result. If the resulting gas is negative,\n an error [Gas.Operation_quota_exceeded] is instead returned. *)\nval consume :\n local_gas_counter -> Alpha_context.Gas.cost -> local_gas_counter tzresult\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\n(*\n\n Gas update and check for gas exhaustion\n =======================================\n\n Costs of various computations are subtracted from an amount of gas made\n available for the script execution.\n\n Updating the gas counter is a critical aspect to operation validation\n because it is done at many places.\n\n For this reason, the gas counter must be read and updated as quickly as\n possible. Hence, the gas counter should be stored in a machine register. To\n motivate the OCaml compiler to make that choice, we represent the gas counter\n as a local parameter of the execution [step] function.\n\n*)\n\ntype local_gas_counter = Local_gas_counter of int [@@ocaml.unboxed]\n\n(*\n\n The gas counter stored in the context is de-synchronized with the\n [local_gas_counter] used locally. When we have to call a gas-consuming\n function working on context with no local gas counter, we must update the\n context so that it carries an up-to-date gas counter. Similarly, when we\n return from such a function, the [local_gas_counter] must be updated as well.\n\n To statically track these points where the context's gas counter must be\n updated, we introduce a type for outdated contexts. The [step] function\n carries an [outdated_context]. When an external function needs a [context],\n the typechecker points out the need for a conversion: this forces us to\n either call [update_context], or better, when this is possible, the function\n [use_gas_counter_in_context].\n*)\ntype outdated_context = Outdated_context of context [@@ocaml.unboxed]\n\nlet outdated_context ctxt = Outdated_context ctxt [@@ocaml.inline always]\n\nlet update_context (Local_gas_counter gas_counter) (Outdated_context ctxt) =\n Gas.update_remaining_operation_gas ctxt (Gas.fp_of_milligas_int gas_counter)\n [@@ocaml.inline always]\n\nlet local_gas_counter ctxt =\n Local_gas_counter (Gas.remaining_operation_gas ctxt :> int)\n [@@ocaml.inline always]\n\nlet local_gas_counter_and_outdated_context ctxt =\n (local_gas_counter ctxt, outdated_context ctxt)\n [@@ocaml.inline always]\n\nlet use_gas_counter_in_context ctxt gas_counter f =\n let ctxt = update_context gas_counter ctxt in\n f ctxt >|=? fun (y, ctxt) -> (y, outdated_context ctxt, local_gas_counter ctxt)\n [@@ocaml.inline always]\n\nlet consume_opt (Local_gas_counter gas_counter) (cost : Gas.cost) =\n let gas_counter = gas_counter - (cost :> int) in\n if Compare.Int.(gas_counter < 0) then None\n else Some (Local_gas_counter gas_counter)\n [@@ocaml.inline always]\n\nlet consume local_gas_counter cost =\n match consume_opt local_gas_counter cost with\n | None -> error Gas.Operation_quota_exceeded\n | Some local_gas_counter -> Ok local_gas_counter\n [@@ocaml.inline always]\n" ;
} ;
{ name = "Script_tc_errors" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\nopen Script\n\n(* ---- Error definitions ---------------------------------------------------*)\n\ntype kind = Int_kind | String_kind | Bytes_kind | Prim_kind | Seq_kind\n\ntype unparsed_stack_ty = Script.expr list\n\ntype type_map = (Script.location * (unparsed_stack_ty * unparsed_stack_ty)) list\n\n(* Structure errors *)\ntype error += Invalid_arity of Script.location * prim * int * int\n\ntype error += Invalid_seq_arity of Script.location * int * int\n\ntype error +=\n | Invalid_namespace of\n Script.location\n * prim\n * Michelson_v1_primitives.namespace\n * Michelson_v1_primitives.namespace\n\ntype error += Invalid_primitive of Script.location * prim list * prim\n\ntype error += Invalid_kind of Script.location * kind list * kind\n\ntype error += Invalid_never_expr of Script.location\n\ntype error += Missing_field of prim\n\ntype error += Duplicate_field of Script.location * prim\n\ntype error += Unexpected_lazy_storage of Script.location\n\ntype error += Unexpected_operation of Script.location\n\ntype error += Unexpected_contract of Script.location\n\ntype error += No_such_entrypoint of Entrypoint.t\n\ntype error += Duplicate_entrypoint of Entrypoint.t\n\ntype error += Unreachable_entrypoint of prim list\n\n(* Transaction rollup errors *)\n\ntype error += Tx_rollup_bad_deposit_parameter of Script.location * Script.expr\n\ntype error += Tx_rollup_invalid_ticket_amount of Z.t\n\ntype error += Forbidden_zero_ticket_quantity\n\ntype error += Tx_rollup_addresses_disabled of Script.location\n\n(* Smart-contract rollup errors *)\n\ntype error += Sc_rollup_disabled of Script.location\n\n(* Zero Knowledge rollup errors *)\n\ntype error += Zk_rollup_disabled of Script.location\n\ntype error += Zk_rollup_bad_deposit_parameter of Script.location * Script.expr\n\n(* Instruction typing errors *)\ntype error += Fail_not_in_tail_position of Script.location\n\ntype error +=\n | Undefined_binop :\n Script.location * prim * Script.expr * Script.expr\n -> error\n\ntype error += Undefined_unop : Script.location * prim * Script.expr -> error\n\ntype error +=\n | Bad_return : Script.location * unparsed_stack_ty * Script.expr -> error\n\ntype error +=\n | Bad_stack : Script.location * prim * int * unparsed_stack_ty -> error\n\ntype error +=\n | Unmatched_branches :\n Script.location * unparsed_stack_ty * unparsed_stack_ty\n -> error\n\n(* View errors *)\ntype error += View_name_too_long of string\n\ntype error += Bad_view_name of Script.location\n\ntype error +=\n | Ill_typed_view of {\n loc : Script.location;\n actual : unparsed_stack_ty;\n expected : unparsed_stack_ty;\n }\n\ntype error += Duplicated_view_name of Script.location\n\ntype context_desc = Lambda | View\n\ntype error +=\n | Forbidden_instr_in_context of Script.location * context_desc * prim\n\ntype error += Bad_stack_length\n\ntype error += Bad_stack_item of int\n\ntype error += Unexpected_annotation of Script.location\n\ntype error += Ungrouped_annotations of Script.location\n\ntype error += Invalid_map_body : Script.location * unparsed_stack_ty -> error\n\ntype error += Invalid_map_block_fail of Script.location\n\ntype error +=\n | Invalid_iter_body :\n Script.location * unparsed_stack_ty * unparsed_stack_ty\n -> error\n\ntype error += Type_too_large : Script.location * int -> error\n\ntype error += Pair_bad_argument of Script.location\n\ntype error += Unpair_bad_argument of Script.location\n\ntype error += Dup_n_bad_argument of Script.location\n\ntype error += Dup_n_bad_stack of Script.location\n\n(* Value typing errors *)\ntype error +=\n | Invalid_constant : Script.location * Script.expr * Script.expr -> error\n\ntype error +=\n | Invalid_syntactic_constant : Script.location * Script.expr * string -> error\n\ntype error += Invalid_contract of Script.location * Contract.t\n\ntype error += Invalid_big_map of Script.location * Big_map.Id.t\n\ntype error += Comparable_type_expected : Script.location * Script.expr -> error\n\ntype error += Inconsistent_type_sizes : int * int -> error\n\ntype error +=\n | Inconsistent_types : Script.location * Script.expr * Script.expr -> error\n\ntype error +=\n | Inconsistent_memo_sizes : Sapling.Memo_size.t * Sapling.Memo_size.t -> error\n\ntype error += Unordered_map_keys of Script.location * Script.expr\n\ntype error += Unordered_set_values of Script.location * Script.expr\n\ntype error += Duplicate_map_keys of Script.location * Script.expr\n\ntype error += Duplicate_set_values of Script.location * Script.expr\n\n(* Toplevel errors *)\ntype error +=\n | Ill_typed_data : string option * Script.expr * Script.expr -> error\n\ntype error += Ill_formed_type of string option * Script.expr * Script.location\n\ntype error += Ill_typed_contract : Script.expr * type_map -> error\n\n(* Deprecation errors *)\ntype error += Deprecated_instruction of prim\n\n(* Stackoverflow errors *)\ntype error += Typechecking_too_many_recursive_calls\n\ntype error += Unparsing_too_many_recursive_calls\n\n(* Ticket errors *)\ntype error += Unexpected_ticket of Script.location\n\ntype error += Unexpected_forged_value of Script.location\n\ntype error += Non_dupable_type of Script.location * Script.expr\n\ntype error += Unexpected_ticket_owner of Destination.t\n\n(* Merge type errors *)\n\ntype inconsistent_types_fast_error =\n | Inconsistent_types_fast\n (** This value is only used when the details of the error don't matter because\nthe error will be ignored later. For example, when types are compared during\nthe interpretation of the [CONTRACT] instruction any error will lead to\nreturning [None] but the content of the error will be ignored. *)\n\ntype (_, _) error_details =\n | Informative : 'error_context -> ('error_context, error trace) error_details\n | Fast : (_, inconsistent_types_fast_error) error_details\n" ;
} ;
{ name = "Gas_monad" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This monad combines:\n - a state monad where the state is the context\n - two levels of error monad to distinguish gas exhaustion from other errors\n\n It is useful for backtracking on type checking errors without backtracking\n the consumed gas.\n*)\ntype ('a, 'trace) t\n\n(** Alias of [('a, 'trace) t] to avoid confusion when the module is open *)\ntype ('a, 'trace) gas_monad = ('a, 'trace) t\n\n(** [return x] returns a value in the gas-monad. *)\nval return : 'a -> ('a, 'trace) t\n\n(** [map f m] maps over successful results of [m] using [f]. *)\nval map : ('a -> 'b) -> ('a, 'trace) t -> ('b, 'trace) t\n\n(** [bind m f] binds successful results of [m] and feeds it to [f]. *)\nval bind : ('a, 'trace) t -> ('a -> ('b, 'trace) t) -> ('b, 'trace) t\n\n(** [bind_recover m f] binds the result of [m] and feeds it to [f]. It's another\n variant of [bind] that allows recovery from inner errors. *)\nval bind_recover :\n ('a, 'trace) t -> (('a, 'trace) result -> ('b, 'trace') t) -> ('b, 'trace') t\n\n(** [of_result r] is a gas-free embedding of the result [r] into the gas monad. *)\nval of_result : ('a, 'trace) result -> ('a, 'trace) t\n\n(** [consume_gas c] consumes c amounts of gas. It's a wrapper around\n [Gas.consume]. If that fails, the whole computation within the gas-monad\n returns an error. See the {!Alpha_context.Gas module} for details.*)\nval consume_gas : Alpha_context.Gas.cost -> (unit, 'trace) t\n\n(** [run ctxt m] runs [m] using the given context and returns the result along\n with the new context with updated gas. The given context has [unlimited]\n mode enabled, through [Gas.set_unlimited], no gas is consumed. *)\nval run :\n Alpha_context.context ->\n ('a, 'trace) t ->\n (('a, 'trace) result * Alpha_context.context) tzresult\n\n(** [record_trace_level ~error_details f m] returns a new gas-monad value that\n when run, records trace levels using [f]. This function has no effect in\n the case of a gas-exhaustion error or if [error_details] is [Fast]. *)\nval record_trace_eval :\n error_details:('error_context, 'error_trace) Script_tc_errors.error_details ->\n ('error_context -> error) ->\n ('a, 'error_trace) t ->\n ('a, 'error_trace) t\n\n(** [fail e] is [return (Error e)] . *)\nval fail : 'trace -> ('a, 'trace) t\n\n(** Syntax module for the {!Gas_monad}. This is intended to be opened locally in\n functions. Within the scope of this module, the code can include binding\n operators, leading to a [let]-style syntax. Similar to {!Lwt_result_syntax}\n and other syntax modules. *)\nmodule Syntax : sig\n (** [return x] returns a value in the gas-monad. *)\n val return : 'a -> ('a, 'trace) t\n\n (** [return_unit] is [return ()] . *)\n val return_unit : (unit, 'trace) t\n\n (** [return_none] is [return None] . *)\n val return_none : ('a option, 'trace) t\n\n (** [return_some x] is [return (Some x)] . *)\n val return_some : 'a -> ('a option, 'trace) t\n\n (** [return_nil] is [return []] . *)\n val return_nil : ('a list, 'trace) t\n\n (** [return_true] is [return true] . *)\n val return_true : (bool, 'trace) t\n\n (** [return_false] is [return false] . *)\n val return_false : (bool, 'trace) t\n\n (** [fail e] is [return (Error e)] . *)\n val fail : 'trace -> ('a, 'trace) t\n\n (** [let*] is a binding operator alias for {!bind}. *)\n val ( let* ) : ('a, 'trace) t -> ('a -> ('b, 'trace) t) -> ('b, 'trace) t\n\n (** [let+] is a binding operator alias for {!map}. *)\n val ( let+ ) : ('a, 'trace) t -> ('a -> 'b) -> ('b, 'trace) t\n\n (** [let*?] is for binding the value from result-only expressions into the\n gas-monad. *)\n val ( let*? ) :\n ('a, 'trace) result -> ('a -> ('b, 'trace) t) -> ('b, 'trace) t\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2021 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\n(* The outer option is for gas exhaustion. The inner [result] is for all other\n errors. *)\ntype ('a, 'trace) t =\n Local_gas_counter.local_gas_counter ->\n (('a, 'trace) result * Local_gas_counter.local_gas_counter) option\n\ntype ('a, 'trace) gas_monad = ('a, 'trace) t\n\nlet of_result x gas = Some (x, gas) [@@ocaml.inline always]\n\nlet return x = of_result (ok x) [@@ocaml.inline always]\n\nlet return_unit = return ()\n\n(* Inlined [Option.bind] for performance. *)\nlet ( >>?? ) m f = match m with None -> None | Some x -> f x\n [@@ocaml.inline always]\n\nlet bind m f gas =\n m gas >>?? fun (res, gas) ->\n match res with Ok y -> f y gas | Error _ as err -> of_result err gas\n [@@ocaml.inline always]\n\nlet map f m gas = m gas >>?? fun (x, gas) -> of_result (x >|? f) gas\n [@@ocaml.inline always]\n\nlet bind_result m f = bind (of_result m) f [@@ocaml.inline always]\n\nlet bind_recover m f gas = m gas >>?? fun (x, gas) -> f x gas\n [@@ocaml.inline always]\n\nlet consume_gas cost gas =\n match Local_gas_counter.consume_opt gas cost with\n | None -> None\n | Some gas -> Some (ok (), gas)\n\nlet run ctxt m =\n let open Local_gas_counter in\n match Gas.level ctxt with\n | Gas.Unaccounted -> (\n match m (Local_gas_counter (Saturation_repr.saturated :> int)) with\n | Some (res, _new_gas_counter) -> ok (res, ctxt)\n | None -> error Gas.Operation_quota_exceeded)\n | Limited {remaining = _} -> (\n let gas_counter, outdated_ctxt =\n local_gas_counter_and_outdated_context ctxt\n in\n match m gas_counter with\n | Some (res, new_gas_counter) ->\n let ctxt = update_context new_gas_counter outdated_ctxt in\n ok (res, ctxt)\n | None -> error Gas.Operation_quota_exceeded)\n\nlet record_trace_eval :\n type error_trace error_context.\n error_details:(error_context, error_trace) Script_tc_errors.error_details ->\n (error_context -> error) ->\n ('a, error_trace) t ->\n ('a, error_trace) t =\n fun ~error_details ->\n match error_details with\n | Fast -> fun _f m -> m\n | Informative err_ctxt ->\n fun f m gas ->\n m gas >>?? fun (x, gas) ->\n of_result (record_trace_eval (fun () -> f err_ctxt) x) gas\n\nlet fail e = of_result (Error e) [@@ocaml.inline always]\n\nmodule Syntax = struct\n let return = return\n\n let return_unit = return_unit\n\n let return_none = return None\n\n let return_some x = return (Some x)\n\n let return_nil = return []\n\n let return_true = return true\n\n let return_false = return false\n\n let fail = fail\n\n let ( let* ) = bind\n\n let ( let+ ) m f = map f m\n\n let ( let*? ) = bind_result\nend\n" ;
} ;
{ name = "Script_ir_annot" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2019-2022 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\n(** @return an error {!Unexpected_annotation} in the monad the list is not empty. *)\nval error_unexpected_annot : Script.location -> 'a list -> unit tzresult\n\n(** check_xxx_annot functions below are remains from the past (they were called\n parse_xxx_annot before).\n They check that annotations are well-formed and, depending on different\n contexts, that only the annotations that are expected to be found are\n present.\n Hopefully we will relax this property soon.\n*)\n\n(** Check a type annotation only. *)\nval check_type_annot : Script.location -> string list -> unit tzresult\n\n(** Check a field annotation only. *)\nval is_field_annot : Script.location -> string -> bool tzresult\n\n(** Check an annotation for composed types, of the form\n [:ty_name %field1 %field2] in any order. *)\nval check_composed_type_annot : Script.location -> string list -> unit tzresult\n\n(** Checks whether a node has a field annotation. *)\nval has_field_annot : Script.node -> bool tzresult\n\n(** Removes a field annotation from a node. *)\nval remove_field_annot : Script.node -> Script.node tzresult\n\n(** Extract and remove a field annotation as an entrypoint from a node *)\nval extract_entrypoint_annot :\n Script.node -> (Script.node * Entrypoint.t option) tzresult\n\n(** Instruction annotations parsing *)\n\n(** Check a variable annotation. *)\nval check_var_annot : Script.location -> string list -> unit tzresult\n\nval is_allowed_char : char -> bool\n\nval check_constr_annot : Script.location -> string list -> unit tzresult\n\nval check_two_var_annot : Script.location -> string list -> unit tzresult\n\nval check_destr_annot : Script.location -> string list -> unit tzresult\n\nval check_unpair_annot : Script.location -> string list -> unit tzresult\n\n(** Parses a field annotation and converts it to an entrypoint.\n An error is returned if the annotation is too long or is \"default\".\n An empty annotation is converted to \"default\". *)\nval parse_entrypoint_annot_strict :\n Script.location -> string list -> Entrypoint.t tzresult\n\n(** Parse a field annotation and convert it to an entrypoint.\n An error is returned if the field annot is too long.\n An empty annotation is converted to \"default\". *)\nval parse_entrypoint_annot_lax :\n Script.location -> string list -> Entrypoint.t tzresult\n\nval check_var_type_annot : Script.location -> string list -> unit tzresult\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2019-2022 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\nopen Micheline\nopen Script_tc_errors\n\ntype var_annot = Var_annot\n\ntype type_annot = Type_annot\n\ntype field_annot = Field_annot of Non_empty_string.t [@@ocaml.unboxed]\n\nlet error_unexpected_annot loc annot =\n match annot with\n | [] -> Result.return_unit\n | _ :: _ -> error (Unexpected_annotation loc)\n\n(* Check that the predicate p holds on all s.[k] for k >= i *)\nlet string_iter p s i =\n let len = String.length s in\n let rec aux i =\n if Compare.Int.(i >= len) then Result.return_unit\n else p s.[i] >>? fun () -> aux (i + 1)\n in\n aux i\n\nlet is_allowed_char = function\n | 'a' .. 'z' | 'A' .. 'Z' | '_' | '.' | '%' | '@' | '0' .. '9' -> true\n | _ -> false\n\n(* Valid annotation characters as defined by the allowed_annot_char function from lib_micheline/micheline_parser *)\nlet check_char loc c =\n if is_allowed_char c then Result.return_unit\n else error (Unexpected_annotation loc)\n\n(* This constant is defined in lib_micheline/micheline_parser which is not available in the environment. *)\nlet max_annot_length = 255\n\ntype annot_opt =\n | Field_annot_opt of Non_empty_string.t option\n | Type_annot_opt of type_annot option\n | Var_annot_opt of var_annot option\n\nlet at = Non_empty_string.of_string_exn \"@\"\n\nlet parse_annot loc s =\n (* allow empty annotations as wildcards but otherwise only accept\n annotations that start with [a-zA-Z_] *)\n let sub_or_wildcard wrap s =\n match Non_empty_string.of_string s with\n | None -> ok @@ wrap None\n | Some s -> (\n match (s :> string).[0] with\n | 'a' .. 'z' | 'A' .. 'Z' | '_' | '0' .. '9' ->\n (* check that all characters are valid*)\n string_iter (check_char loc) (s :> string) 1 >>? fun () ->\n ok @@ wrap (Some s)\n | _ -> error (Unexpected_annotation loc))\n in\n let len = String.length s in\n if Compare.Int.(len = 0 || len > max_annot_length) then\n error (Unexpected_annotation loc)\n else\n let rest = String.sub s 1 (len - 1) in\n match s.[0] with\n | ':' ->\n sub_or_wildcard\n (fun a ->\n Type_annot_opt\n (Option.map (fun (_ : Non_empty_string.t) -> Type_annot) a))\n rest\n | '@' ->\n sub_or_wildcard\n (fun a ->\n Var_annot_opt\n (Option.map (fun (_ : Non_empty_string.t) -> Var_annot) a))\n rest\n | '%' -> sub_or_wildcard (fun a -> Field_annot_opt a) rest\n | _ -> error (Unexpected_annotation loc)\n\nlet parse_annots loc ?(allow_special_var = false) ?(allow_special_field = false)\n l =\n List.map_e\n (function\n | \"@%\" when allow_special_var -> ok @@ Var_annot_opt (Some Var_annot)\n | \"@%%\" when allow_special_var -> ok @@ Var_annot_opt (Some Var_annot)\n | \"%@\" when allow_special_field -> ok @@ Field_annot_opt (Some at)\n | s -> parse_annot loc s)\n l\n\nlet opt_field_of_field_opt = function\n | None -> None\n | Some a -> Some (Field_annot a)\n\nlet classify_annot loc l :\n (var_annot option list * type_annot option list * field_annot option list)\n tzresult =\n try\n let _, rv, _, rt, _, rf =\n List.fold_left\n (fun (in_v, rv, in_t, rt, in_f, rf) a ->\n match (a, in_v, rv, in_t, rt, in_f, rf) with\n | Var_annot_opt a, true, _, _, _, _, _\n | Var_annot_opt a, false, [], _, _, _, _ ->\n (true, a :: rv, false, rt, false, rf)\n | Type_annot_opt a, _, _, true, _, _, _\n | Type_annot_opt a, _, _, false, [], _, _ ->\n (false, rv, true, a :: rt, false, rf)\n | Field_annot_opt a, _, _, _, _, true, _\n | Field_annot_opt a, _, _, _, _, false, [] ->\n (false, rv, false, rt, true, opt_field_of_field_opt a :: rf)\n | _ -> raise Exit)\n (false, [], false, [], false, [])\n l\n in\n ok (List.rev rv, List.rev rt, List.rev rf)\n with Exit -> error (Ungrouped_annotations loc)\n\nlet get_one_annot loc = function\n | [] -> Result.return_none\n | [a] -> ok a\n | _ -> error (Unexpected_annotation loc)\n\nlet get_two_annot loc = function\n | [] -> ok (None, None)\n | [a] -> ok (a, None)\n | [a; b] -> ok (a, b)\n | _ -> error (Unexpected_annotation loc)\n\nlet check_type_annot loc annot =\n parse_annots loc annot >>? classify_annot loc >>? fun (vars, types, fields) ->\n error_unexpected_annot loc vars >>? fun () ->\n error_unexpected_annot loc fields >>? fun () ->\n get_one_annot loc types >|? fun (_a : type_annot option) -> ()\n\nlet check_composed_type_annot loc annot =\n parse_annots loc annot >>? classify_annot loc >>? fun (vars, types, fields) ->\n error_unexpected_annot loc vars >>? fun () ->\n get_one_annot loc types >>? fun (_t : type_annot option) ->\n get_two_annot loc fields >|? fun (_f1, _f2) -> ()\n\nlet parse_field_annot :\n Script.location -> string -> Non_empty_string.t option tzresult =\n fun loc annot ->\n if Compare.Int.(String.length annot <= 0) || Compare.Char.(annot.[0] <> '%')\n then Result.return_none\n else\n parse_annot loc annot >|? function\n | Field_annot_opt annot_opt -> annot_opt\n | _ -> None\n\nlet is_field_annot loc a = parse_field_annot loc a >|? Option.is_some\n\nlet extract_field_annot :\n Script.node -> (Script.node * Non_empty_string.t option) tzresult = function\n | Prim (loc, prim, args, annot) as expr ->\n let rec extract_first acc = function\n | [] -> ok (expr, None)\n | s :: rest -> (\n parse_field_annot loc s >>? function\n | None -> extract_first (s :: acc) rest\n | Some _ as some_field_annot ->\n let annot = List.rev_append acc rest in\n ok (Prim (loc, prim, args, annot), some_field_annot))\n in\n extract_first [] annot\n | expr -> ok (expr, None)\n\nlet has_field_annot node =\n extract_field_annot node >|? function\n | _node, Some _ -> true\n | _node, None -> false\n\nlet remove_field_annot node =\n extract_field_annot node >|? fun (node, _a) -> node\n\nlet extract_entrypoint_annot node =\n extract_field_annot node >|? fun (node, field_annot_opt) ->\n ( node,\n Option.bind field_annot_opt (fun field_annot ->\n Entrypoint.of_annot_lax_opt field_annot) )\n\nlet check_var_annot loc annot =\n parse_annots loc annot >>? classify_annot loc >>? fun (vars, types, fields) ->\n error_unexpected_annot loc types >>? fun () ->\n error_unexpected_annot loc fields >>? fun () ->\n get_one_annot loc vars >|? fun (_a : var_annot option) -> ()\n\nlet check_constr_annot loc annot =\n parse_annots ~allow_special_field:true loc annot >>? classify_annot loc\n >>? fun (vars, types, fields) ->\n get_one_annot loc vars >>? fun (_v : var_annot option) ->\n get_one_annot loc types >>? fun (_t : type_annot option) ->\n get_two_annot loc fields >|? fun (_f1, _f2) -> ()\n\nlet check_two_var_annot loc annot =\n parse_annots loc annot >>? classify_annot loc >>? fun (vars, types, fields) ->\n error_unexpected_annot loc types >>? fun () ->\n error_unexpected_annot loc fields >>? fun () ->\n get_two_annot loc vars >|? fun (_a1, _a2) -> ()\n\nlet check_destr_annot loc annot =\n parse_annots loc ~allow_special_var:true annot >>? classify_annot loc\n >>? fun (vars, types, fields) ->\n error_unexpected_annot loc types >>? fun () ->\n get_one_annot loc vars >>? fun (_v : var_annot option) ->\n get_one_annot loc fields >|? fun (_f : field_annot option) -> ()\n\nlet check_unpair_annot loc annot =\n parse_annots loc ~allow_special_var:true annot >>? classify_annot loc\n >>? fun (vars, types, fields) ->\n error_unexpected_annot loc types >>? fun () ->\n get_two_annot loc vars >>? fun (_vcar, _vcdr) ->\n get_two_annot loc fields >|? fun (_f1, _f2) -> ()\n\nlet parse_entrypoint_annot loc annot =\n parse_annots loc annot >>? classify_annot loc >>? fun (vars, types, fields) ->\n error_unexpected_annot loc types >>? fun () ->\n get_one_annot loc fields >>? fun f ->\n get_one_annot loc vars >|? fun (_v : var_annot option) -> f\n\nlet parse_entrypoint_annot_strict loc annot =\n parse_entrypoint_annot loc annot >>? function\n | None -> Ok Entrypoint.default\n | Some (Field_annot a) -> Entrypoint.of_annot_strict ~loc a\n\nlet parse_entrypoint_annot_lax loc annot =\n parse_entrypoint_annot loc annot >>? function\n | None -> Ok Entrypoint.default\n | Some (Field_annot annot) -> Entrypoint.of_annot_lax annot\n\nlet check_var_type_annot loc annot =\n parse_annots loc annot >>? classify_annot loc >>? fun (vars, types, fields) ->\n error_unexpected_annot loc fields >>? fun () ->\n get_one_annot loc vars >>? fun (_v : var_annot option) ->\n get_one_annot loc types >|? fun (_t : type_annot option) -> ()\n" ;
} ;
{ name = "Dependent_bool" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Dependent booleans *)\n\ntype no = private DNo\n\ntype yes = private DYes\n\n(** \n ['b dbool] is a boolean whose value depends on its type parameter ['b].\n [yes dbool] can only be [Yes]. [no dbool] can only be [No].\n*)\ntype _ dbool = No : no dbool | Yes : yes dbool\n\n(** \n [('a, 'b, 'r) dand] is a witness of the logical conjunction of dependent\n booleans. ['r] is the result of ['a] and ['b].\n*)\ntype ('a, 'b, 'r) dand =\n | NoNo : (no, no, no) dand\n | NoYes : (no, yes, no) dand\n | YesNo : (yes, no, no) dand\n | YesYes : (yes, yes, yes) dand\n\ntype ('a, 'b) ex_dand = Ex_dand : ('a, 'b, _) dand -> ('a, 'b) ex_dand\n[@@unboxed]\n\n(** Logical conjunction of dependent booleans. *)\nval dand : 'a dbool -> 'b dbool -> ('a, 'b) ex_dand\n\n(** Result of the logical conjunction of dependent booleans. *)\nval dbool_of_dand : ('a, 'b, 'r) dand -> 'r dbool\n\n(** Type equality witness. *)\ntype (_, _) eq = Eq : ('a, 'a) eq\n\n(**\n [merge_dand] proves that the type [dand] represents a function, i.e. that\n there is a unique ['r] such that [('a, 'b, 'r) dand] is inhabited for a\n given ['a] and a given ['b].\n*)\nval merge_dand : ('a, 'b, 'c1) dand -> ('a, 'b, 'c2) dand -> ('c1, 'c2) eq\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype no = private DNo\n\ntype yes = private DYes\n\ntype _ dbool = No : no dbool | Yes : yes dbool\n\ntype ('a, 'b, 'r) dand =\n | NoNo : (no, no, no) dand\n | NoYes : (no, yes, no) dand\n | YesNo : (yes, no, no) dand\n | YesYes : (yes, yes, yes) dand\n\ntype ('a, 'b) ex_dand = Ex_dand : ('a, 'b, _) dand -> ('a, 'b) ex_dand\n[@@unboxed]\n\nlet dand : type a b. a dbool -> b dbool -> (a, b) ex_dand =\n fun a b ->\n match (a, b) with\n | No, No -> Ex_dand NoNo\n | No, Yes -> Ex_dand NoYes\n | Yes, No -> Ex_dand YesNo\n | Yes, Yes -> Ex_dand YesYes\n\nlet dbool_of_dand : type a b r. (a, b, r) dand -> r dbool = function\n | NoNo -> No\n | NoYes -> No\n | YesNo -> No\n | YesYes -> Yes\n\ntype (_, _) eq = Eq : ('a, 'a) eq\n\nlet merge_dand :\n type a b c1 c2. (a, b, c1) dand -> (a, b, c2) dand -> (c1, c2) eq =\n fun w1 w2 ->\n match (w1, w2) with\n | NoNo, NoNo -> Eq\n | NoYes, NoYes -> Eq\n | YesNo, YesNo -> Eq\n | YesYes, YesYes -> Eq\n" ;
} ;
{ name = "Script_list" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype 'elt t = private {elements : 'elt list; length : int}\n\n(** Convert an OCaml list into Michelson list. *)\nval of_list : 'a list -> 'a t\n\n(** Convert a Michelson list to an OCaml list. *)\nval to_list : 'a t -> 'a list\n\n(** [length l] returns the number of elements in [l] as [int]. *)\nval length : 'a t -> int\n\n(** Empty list. *)\nval empty : 'a t\n\n(** Prepend an element. *)\nval cons : 'a -> 'a t -> 'a t\n\n(** [uncons l] returns [Some (hd, tl)] where [hd :: tl = l] if [l] is\n not empty or [None] otherwise. *)\nval uncons : 'a t -> ('a * 'a t) option\n\n(** [rev l] returns a list containing all elements of [l] in reversed order. *)\nval rev : 'a t -> 'a t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype 'elt t = {elements : 'elt list; length : int}\n\nlet of_list l = {elements = l; length = List.length l} [@@inline always]\n\nlet to_list {elements; length = _} = elements [@@inline always]\n\nlet empty : 'a t = {elements = []; length = 0}\n\nlet cons : 'a -> 'a t -> 'a t =\n fun elt l -> {length = 1 + l.length; elements = elt :: l.elements}\n\nlet length {elements = _; length} = length [@@inline always]\n\nlet uncons = function\n | {elements = []; length = _} -> None\n | {elements = hd :: tl; length} ->\n Some (hd, {elements = tl; length = length - 1})\n\nlet rev {elements; length} = {elements = List.rev elements; length}\n [@@inline always]\n" ;
} ;
{ name = "Script_typed_ir" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\nopen Script_int\nopen Dependent_bool\n\n(*\n\n The step function of the interpreter is parametrized by a bunch of values called the step constants.\n These values are indeed constants during the call of a smart contract with the notable exception of\n the IView instruction which modifies `source`, `self`, and `amount` and the KView_exit continuation\n which restores them.\n ======================\n\n*)\ntype step_constants = {\n source : Destination.t;\n (** The address calling this contract, as returned by SENDER. *)\n payer : Signature.public_key_hash;\n (** The address of the implicit account that initiated the chain of contract calls, as returned by SOURCE. *)\n self : Contract_hash.t;\n (** The address of the contract being executed, as returned by SELF and SELF_ADDRESS.\n Also used:\n - as ticketer in TICKET\n - as caller in VIEW, TRANSFER_TOKENS, and CREATE_CONTRACT *)\n amount : Tez.t;\n (** The amount of the current transaction, as returned by AMOUNT. *)\n balance : Tez.t; (** The balance of the contract as returned by BALANCE. *)\n chain_id : Chain_id.t;\n (** The chain id of the chain, as returned by CHAIN_ID. *)\n now : Script_timestamp.t;\n (** The earliest time at which the current block could have been timestamped, as returned by NOW. *)\n level : Script_int.n Script_int.num;\n (** The level of the current block, as returned by LEVEL. *)\n}\n\n(* Preliminary definitions. *)\n\ntype never = |\n\ntype address = {destination : Destination.t; entrypoint : Entrypoint.t}\n\nmodule Script_signature : sig\n (** [t] is made algebraic in order to distinguish it from the other type\n parameters of [Script_typed_ir.ty]. *)\n type t = Signature_tag of signature [@@ocaml.unboxed]\n\n val make : signature -> t\n\n val get : t -> signature\n\n val encoding : t Data_encoding.t\n\n val of_b58check_opt : string -> t option\n\n val check :\n ?watermark:Signature.watermark ->\n Signature.Public_key.t ->\n t ->\n Bytes.t ->\n bool\n\n val compare : t -> t -> int\n\n val size : t -> int\nend\n\ntype signature = Script_signature.t\n\ntype tx_rollup_l2_address = Tx_rollup_l2_address.Indexable.value\n\ntype ('a, 'b) pair = 'a * 'b\n\ntype ('a, 'b) union = L of 'a | R of 'b\n\nmodule Script_chain_id : sig\n (** [t] is made algebraic in order to distinguish it from the other type\n parameters of [Script_typed_ir.ty]. *)\n type t = Chain_id_tag of Chain_id.t [@@ocaml.unboxed]\n\n val make : Chain_id.t -> t\n\n val compare : t -> t -> int\n\n val size : int\n\n val encoding : t Data_encoding.t\n\n val to_b58check : t -> string\n\n val of_b58check_opt : string -> t option\nend\n\nmodule Script_bls : sig\n module type S = sig\n type t\n\n type fr\n\n val add : t -> t -> t\n\n val mul : t -> fr -> t\n\n val negate : t -> t\n\n val of_bytes_opt : Bytes.t -> t option\n\n val to_bytes : t -> Bytes.t\n end\n\n module Fr : sig\n (** [t] is made algebraic in order to distinguish it from the other type\n parameters of [Script_typed_ir.ty]. *)\n type t = Fr_tag of Bls.Primitive.Fr.t [@@ocaml.unboxed]\n\n include S with type t := t and type fr := t\n\n val of_z : Z.t -> t\n\n val to_z : t -> Z.t\n end\n\n module G1 : sig\n (** [t] is made algebraic in order to distinguish it from the other type\n parameters of [Script_typed_ir.ty]. *)\n type t = G1_tag of Bls.Primitive.G1.t [@@ocaml.unboxed]\n\n include S with type t := t and type fr := Fr.t\n end\n\n module G2 : sig\n (** [t] is made algebraic in order to distinguish it from the other type\n parameters of [Script_typed_ir.ty]. *)\n type t = G2_tag of Bls.Primitive.G2.t [@@ocaml.unboxed]\n\n include S with type t := t and type fr := Fr.t\n end\n\n val pairing_check : (G1.t * G2.t) list -> bool\nend\n\nmodule Script_timelock : sig\n (** [chest_key] is made algebraic in order to distinguish it from the other\n type parameters of [Script_typed_ir.ty]. *)\n type chest_key = Chest_key_tag of Timelock.chest_key [@@ocaml.unboxed]\n\n val make_chest_key : Timelock.chest_key -> chest_key\n\n val chest_key_encoding : chest_key Data_encoding.t\n\n (** [chest] is made algebraic in order to distinguish it from the other type\n parameters of [Script_typed_ir.ty]. *)\n type chest = Chest_tag of Timelock.chest [@@ocaml.unboxed]\n\n val make_chest : Timelock.chest -> chest\n\n val chest_encoding : chest Data_encoding.t\n\n val open_chest : chest -> chest_key -> time:int -> Timelock.opening_result\n\n val get_plaintext_size : chest -> int\nend\n\ntype ticket_amount = Ticket_amount.t\n\ntype 'a ticket = {ticketer : Contract.t; contents : 'a; amount : ticket_amount}\n\ntype empty_cell = EmptyCell\n\ntype end_of_stack = empty_cell * empty_cell\n\nmodule Type_size : sig\n type 'a t\n\n val check_eq :\n error_details:('error_context, 'error_trace) Script_tc_errors.error_details ->\n 'a t ->\n 'b t ->\n (unit, 'error_trace) result\n\n val to_int : 'a t -> Saturation_repr.mul_safe Saturation_repr.t\nend\n\ntype 'a ty_metadata = {size : 'a Type_size.t} [@@unboxed]\n\nmodule type Boxed_set_OPS = sig\n type t\n\n type elt\n\n val elt_size : elt -> int (* Gas_input_size.t *)\n\n val empty : t\n\n val add : elt -> t -> t\n\n val mem : elt -> t -> bool\n\n val remove : elt -> t -> t\n\n val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a\nend\n\nmodule type Boxed_set = sig\n type elt\n\n module OPS : Boxed_set_OPS with type elt = elt\n\n val boxed : OPS.t\n\n val size : int\nend\n\n(** [set] is made algebraic in order to distinguish it from the other type\n parameters of [ty]. *)\ntype 'elt set = Set_tag of (module Boxed_set with type elt = 'elt)\n[@@ocaml.unboxed]\n\nmodule type Boxed_map_OPS = sig\n type 'a t\n\n type key\n\n val key_size : key -> int (* Gas_input_size.t *)\n\n val empty : 'value t\n\n val add : key -> 'value -> 'value t -> 'value t\n\n val remove : key -> 'value t -> 'value t\n\n val find : key -> 'value t -> 'value option\n\n val fold : (key -> 'value -> 'a -> 'a) -> 'value t -> 'a -> 'a\n\n val fold_es :\n (key -> 'value -> 'a -> 'a tzresult Lwt.t) ->\n 'value t ->\n 'a ->\n 'a tzresult Lwt.t\nend\n\nmodule type Boxed_map = sig\n type key\n\n type value\n\n module OPS : Boxed_map_OPS with type key = key\n\n val boxed : value OPS.t\n\n val size : int\nend\n\n(** [map] is made algebraic in order to distinguish it from the other type\n parameters of [ty]. *)\ntype ('key, 'value) map =\n | Map_tag of (module Boxed_map with type key = 'key and type value = 'value)\n[@@ocaml.unboxed]\n\nmodule Big_map_overlay : Map.S with type key = Script_expr_hash.t\n\ntype ('key, 'value) big_map_overlay = {\n map : ('key * 'value option) Big_map_overlay.t;\n size : int;\n}\n\ntype view = {\n input_ty : Script.node;\n output_ty : Script.node;\n view_code : Script.node;\n}\n\ntype view_map = (Script_string.t, view) map\n\ntype entrypoint_info = {name : Entrypoint.t; original_type_expr : Script.node}\n\n(** ['arg entrypoints] represents the tree of entrypoints of a parameter type\n ['arg].\n [at_node] are entrypoint details at that node if it is not [None].\n [nested] are the entrypoints below the node in the tree.\n It is always [Entrypoints_None] for non-union nodes.\n But it is also ok to have [Entrypoints_None] for a union node, it just\n means that there are no entrypoints below that node in the tree.\n*)\ntype 'arg entrypoints_node = {\n at_node : entrypoint_info option;\n nested : 'arg nested_entrypoints;\n}\n\nand 'arg nested_entrypoints =\n | Entrypoints_Union : {\n left : 'l entrypoints_node;\n right : 'r entrypoints_node;\n }\n -> ('l, 'r) union nested_entrypoints\n | Entrypoints_None : _ nested_entrypoints\n\n(** [no_entrypoints] is [{at_node = None; nested = Entrypoints_None}] *)\nval no_entrypoints : _ entrypoints_node\n\ntype logging_event = LogEntry | LogExit of Script.location\n\ntype 'arg entrypoints = {\n root : 'arg entrypoints_node;\n original_type_expr : Script.node;\n}\n\n(* ---- Instructions --------------------------------------------------------*)\n\n(*\n\n The instructions of Michelson are represented in the following\n Generalized Algebraic Datatypes.\n\n There are three important aspects in that type declaration.\n\n First, we follow a tagless approach for values: they are directly\n represented as OCaml values. This reduces the computational cost of\n interpretation because there is no need to check the shape of a\n value before applying an operation to it. To achieve that, the GADT\n encodes the typing rules of the Michelson programming\n language. This static information is sufficient for the typechecker\n to justify the absence of runtime checks. As a bonus, it also\n ensures that well-typed Michelson programs cannot go wrong: if the\n interpreter typechecks then we have the static guarantee that no\n stack underflow or type error can occur at runtime.\n\n Second, we maintain the invariant that the stack type always has a\n distinguished topmost element. This invariant is important to\n implement the stack as an accumulator followed by a linked list of\n cells, a so-called A-Stack. This representation is considered in\n the literature[1] as an efficient representation of the stack for a\n stack-based abstract machine, mainly because this opens the\n opportunity for the accumulator to be stored in a hardware\n register. In the GADT, this invariant is encoded by representing\n the stack type using two parameters instead of one: the first one\n is the type of the accumulator while the second is the type of the\n rest of the stack.\n\n Third, in this representation, each instruction embeds its\n potential successor instructions in the control flow. This design\n choice permits an efficient implementation of the continuation\n stack in the interpreter. Assigning a precise type to this kind of\n instruction which is a cell in a linked list of instructions is\n similar to the typing of delimited continuations: we need to give a\n type to the stack ['before] the execution of the instruction, a\n type to the stack ['after] the execution of the instruction and\n before the execution of the next, and a type for the [`result]ing\n stack type after the execution of the whole chain of instructions.\n\n Combining these three aspects, the type [kinstr] needs four\n parameters:\n\n ('before_top, 'before, 'result_top, 'result) kinstr\n\n Notice that we could have chosen to only give two parameters to\n [kinstr] by manually enforcing each argument to be a pair but this\n is error-prone: with four parameters, this constraint is enforced\n by the arity of the type constructor itself.\n\n Hence, an instruction which has a successor instruction enjoys a\n type of the form:\n\n ... * ('after_top, 'after, 'result_top, 'result) kinstr * ... ->\n ('before_top, 'before, 'result_top, 'result) kinstr\n\n where ['before_top] and ['before] are the types of the stack top\n and rest before the instruction chain, ['after_top] and ['after]\n are the types of the stack top and rest after the instruction\n chain, and ['result_top] and ['result] are the types of the stack\n top and rest after the instruction chain. The [IHalt] instruction\n ends a sequence of instructions and has no successor, as shown by\n its type:\n\n IHalt : Script.location -> ('a, 's, 'a, 's) kinstr\n\n Each instruction is decorated by its location: its value is only\n used for logging and error reporting and has no impact on the\n operational semantics.\n\n Notations:\n ----------\n\n In the following declaration, we use 'a, 'b, 'c, 'd, ... to assign\n types to stack cell contents while we use 's, 't, 'u, 'v, ... to\n assign types to stacks.\n\n The types for the final result and stack rest of a whole sequence\n of instructions are written 'r and 'f (standing for \"result\" and\n \"final stack rest\", respectively).\n\n Instructions for internal execution steps\n =========================================\n\n Some instructions encoded in the following type are not present in the\n source language. They only appear during evaluation to account for\n intermediate execution steps. Indeed, since the interpreter follows\n a small-step style, it is sometimes necessary to decompose a\n source-level instruction (e.g. List_map) into several instructions\n with smaller steps. This technique seems required to get an\n efficient tail-recursive interpreter.\n\n References\n ==========\n [1]: http://www.complang.tuwien.ac.at/projects/interpreters.html\n\n *)\nand ('before_top, 'before, 'result_top, 'result) kinstr =\n (*\n Stack\n -----\n *)\n | IDrop :\n Script.location * ('b, 's, 'r, 'f) kinstr\n -> ('a, 'b * 's, 'r, 'f) kinstr\n | IDup :\n Script.location * ('a, 'a * ('b * 's), 'r, 'f) kinstr\n -> ('a, 'b * 's, 'r, 'f) kinstr\n | ISwap :\n Script.location * ('b, 'a * ('c * 's), 'r, 'f) kinstr\n -> ('a, 'b * ('c * 's), 'r, 'f) kinstr\n | IConst :\n Script.location * ('ty, _) ty * 'ty * ('ty, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n (*\n Pairs\n -----\n *)\n | ICons_pair :\n Script.location * ('a * 'b, 'c * 's, 'r, 'f) kinstr\n -> ('a, 'b * ('c * 's), 'r, 'f) kinstr\n | ICar :\n Script.location * ('a, 's, 'r, 'f) kinstr\n -> ('a * 'b, 's, 'r, 'f) kinstr\n | ICdr :\n Script.location * ('b, 's, 'r, 'f) kinstr\n -> ('a * 'b, 's, 'r, 'f) kinstr\n | IUnpair :\n Script.location * ('a, 'b * 's, 'r, 'f) kinstr\n -> ('a * 'b, 's, 'r, 'f) kinstr\n (*\n Options\n -------\n *)\n | ICons_some :\n Script.location * ('v option, 'a * 's, 'r, 'f) kinstr\n -> ('v, 'a * 's, 'r, 'f) kinstr\n | ICons_none :\n Script.location * ('b, _) ty * ('b option, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IIf_none : {\n loc : Script.location;\n branch_if_none : ('b, 's, 'c, 't) kinstr;\n branch_if_some : ('a, 'b * 's, 'c, 't) kinstr;\n k : ('c, 't, 'r, 'f) kinstr;\n }\n -> ('a option, 'b * 's, 'r, 'f) kinstr\n | IOpt_map : {\n loc : Script.location;\n body : ('a, 's, 'b, 's) kinstr;\n k : ('b option, 's, 'c, 't) kinstr;\n }\n -> ('a option, 's, 'c, 't) kinstr\n (*\n Unions\n ------\n *)\n | ICons_left :\n Script.location * ('b, _) ty * (('a, 'b) union, 'c * 's, 'r, 'f) kinstr\n -> ('a, 'c * 's, 'r, 'f) kinstr\n | ICons_right :\n Script.location * ('a, _) ty * (('a, 'b) union, 'c * 's, 'r, 'f) kinstr\n -> ('b, 'c * 's, 'r, 'f) kinstr\n | IIf_left : {\n loc : Script.location;\n branch_if_left : ('a, 's, 'c, 't) kinstr;\n branch_if_right : ('b, 's, 'c, 't) kinstr;\n k : ('c, 't, 'r, 'f) kinstr;\n }\n -> (('a, 'b) union, 's, 'r, 'f) kinstr\n (*\n Lists\n -----\n *)\n | ICons_list :\n Script.location * ('a Script_list.t, 's, 'r, 'f) kinstr\n -> ('a, 'a Script_list.t * 's, 'r, 'f) kinstr\n | INil :\n Script.location * ('b, _) ty * ('b Script_list.t, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IIf_cons : {\n loc : Script.location;\n branch_if_cons : ('a, 'a Script_list.t * ('b * 's), 'c, 't) kinstr;\n branch_if_nil : ('b, 's, 'c, 't) kinstr;\n k : ('c, 't, 'r, 'f) kinstr;\n }\n -> ('a Script_list.t, 'b * 's, 'r, 'f) kinstr\n | IList_map :\n Script.location\n * ('a, 'c * 's, 'b, 'c * 's) kinstr\n * ('b Script_list.t, _) ty option\n * ('b Script_list.t, 'c * 's, 'r, 'f) kinstr\n -> ('a Script_list.t, 'c * 's, 'r, 'f) kinstr\n | IList_iter :\n Script.location\n * ('a, _) ty option\n * ('a, 'b * 's, 'b, 's) kinstr\n * ('b, 's, 'r, 'f) kinstr\n -> ('a Script_list.t, 'b * 's, 'r, 'f) kinstr\n | IList_size :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> ('a Script_list.t, 's, 'r, 'f) kinstr\n (*\n Sets\n ----\n *)\n | IEmpty_set :\n Script.location * 'b comparable_ty * ('b set, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | ISet_iter :\n Script.location\n * 'a comparable_ty option\n * ('a, 'b * 's, 'b, 's) kinstr\n * ('b, 's, 'r, 'f) kinstr\n -> ('a set, 'b * 's, 'r, 'f) kinstr\n | ISet_mem :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> ('a, 'a set * 's, 'r, 'f) kinstr\n | ISet_update :\n Script.location * ('a set, 's, 'r, 'f) kinstr\n -> ('a, bool * ('a set * 's), 'r, 'f) kinstr\n | ISet_size :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> ('a set, 's, 'r, 'f) kinstr\n (*\n Maps\n ----\n *)\n | IEmpty_map :\n Script.location\n * 'b comparable_ty\n * ('c, _) ty option\n * (('b, 'c) map, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IMap_map :\n Script.location\n * (('a, 'c) map, _) ty option\n * ('a * 'b, 'd * 's, 'c, 'd * 's) kinstr\n * (('a, 'c) map, 'd * 's, 'r, 'f) kinstr\n -> (('a, 'b) map, 'd * 's, 'r, 'f) kinstr\n | IMap_iter :\n Script.location\n * ('a * 'b, _) ty option\n * ('a * 'b, 'c * 's, 'c, 's) kinstr\n * ('c, 's, 'r, 'f) kinstr\n -> (('a, 'b) map, 'c * 's, 'r, 'f) kinstr\n | IMap_mem :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> ('a, ('a, 'b) map * 's, 'r, 'f) kinstr\n | IMap_get :\n Script.location * ('b option, 's, 'r, 'f) kinstr\n -> ('a, ('a, 'b) map * 's, 'r, 'f) kinstr\n | IMap_update :\n Script.location * (('a, 'b) map, 's, 'r, 'f) kinstr\n -> ('a, 'b option * (('a, 'b) map * 's), 'r, 'f) kinstr\n | IMap_get_and_update :\n Script.location * ('b option, ('a, 'b) map * 's, 'r, 'f) kinstr\n -> ('a, 'b option * (('a, 'b) map * 's), 'r, 'f) kinstr\n | IMap_size :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (('a, 'b) map, 's, 'r, 'f) kinstr\n (*\n Big maps\n --------\n *)\n | IEmpty_big_map :\n Script.location\n * 'b comparable_ty\n * ('c, _) ty\n * (('b, 'c) big_map, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IBig_map_mem :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> ('a, ('a, 'b) big_map * 's, 'r, 'f) kinstr\n | IBig_map_get :\n Script.location * ('b option, 's, 'r, 'f) kinstr\n -> ('a, ('a, 'b) big_map * 's, 'r, 'f) kinstr\n | IBig_map_update :\n Script.location * (('a, 'b) big_map, 's, 'r, 'f) kinstr\n -> ('a, 'b option * (('a, 'b) big_map * 's), 'r, 'f) kinstr\n | IBig_map_get_and_update :\n Script.location * ('b option, ('a, 'b) big_map * 's, 'r, 'f) kinstr\n -> ('a, 'b option * (('a, 'b) big_map * 's), 'r, 'f) kinstr\n (*\n Strings\n -------\n *)\n | IConcat_string :\n Script.location * (Script_string.t, 's, 'r, 'f) kinstr\n -> (Script_string.t Script_list.t, 's, 'r, 'f) kinstr\n | IConcat_string_pair :\n Script.location * (Script_string.t, 's, 'r, 'f) kinstr\n -> (Script_string.t, Script_string.t * 's, 'r, 'f) kinstr\n | ISlice_string :\n Script.location * (Script_string.t option, 's, 'r, 'f) kinstr\n -> (n num, n num * (Script_string.t * 's), 'r, 'f) kinstr\n | IString_size :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (Script_string.t, 's, 'r, 'f) kinstr\n (*\n Bytes\n -----\n *)\n | IConcat_bytes :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes Script_list.t, 's, 'r, 'f) kinstr\n | IConcat_bytes_pair :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, bytes * 's, 'r, 'f) kinstr\n | ISlice_bytes :\n Script.location * (bytes option, 's, 'r, 'f) kinstr\n -> (n num, n num * (bytes * 's), 'r, 'f) kinstr\n | IBytes_size :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (bytes, 's, 'r, 'f) kinstr\n | ILsl_bytes :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, n num * 's, 'r, 'f) kinstr\n | ILsr_bytes :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, n num * 's, 'r, 'f) kinstr\n | IOr_bytes :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, bytes * 's, 'r, 'f) kinstr\n | IAnd_bytes :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, bytes * 's, 'r, 'f) kinstr\n | IXor_bytes :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, bytes * 's, 'r, 'f) kinstr\n | INot_bytes :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, 's, 'r, 'f) kinstr\n | INat_bytes :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (bytes, 's, 'r, 'f) kinstr\n | IBytes_nat :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (n num, 's, 'r, 'f) kinstr\n | IInt_bytes :\n Script.location * (z num, 's, 'r, 'f) kinstr\n -> (bytes, 's, 'r, 'f) kinstr\n | IBytes_int :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (z num, 's, 'r, 'f) kinstr\n (*\n Timestamps\n ----------\n *)\n | IAdd_seconds_to_timestamp :\n Script.location * (Script_timestamp.t, 's, 'r, 'f) kinstr\n -> (z num, Script_timestamp.t * 's, 'r, 'f) kinstr\n | IAdd_timestamp_to_seconds :\n Script.location * (Script_timestamp.t, 's, 'r, 'f) kinstr\n -> (Script_timestamp.t, z num * 's, 'r, 'f) kinstr\n | ISub_timestamp_seconds :\n Script.location * (Script_timestamp.t, 's, 'r, 'f) kinstr\n -> (Script_timestamp.t, z num * 's, 'r, 'f) kinstr\n | IDiff_timestamps :\n Script.location * (z num, 's, 'r, 'f) kinstr\n -> (Script_timestamp.t, Script_timestamp.t * 's, 'r, 'f) kinstr\n (*\n Tez\n ---\n *)\n | IAdd_tez :\n Script.location * (Tez.t, 's, 'r, 'f) kinstr\n -> (Tez.t, Tez.t * 's, 'r, 'f) kinstr\n | ISub_tez :\n Script.location * (Tez.t option, 's, 'r, 'f) kinstr\n -> (Tez.t, Tez.t * 's, 'r, 'f) kinstr\n | ISub_tez_legacy :\n Script.location * (Tez.t, 's, 'r, 'f) kinstr\n -> (Tez.t, Tez.t * 's, 'r, 'f) kinstr\n | IMul_teznat :\n Script.location * (Tez.t, 's, 'r, 'f) kinstr\n -> (Tez.t, n num * 's, 'r, 'f) kinstr\n | IMul_nattez :\n Script.location * (Tez.t, 's, 'r, 'f) kinstr\n -> (n num, Tez.t * 's, 'r, 'f) kinstr\n | IEdiv_teznat :\n Script.location * ((Tez.t, Tez.t) pair option, 's, 'r, 'f) kinstr\n -> (Tez.t, n num * 's, 'r, 'f) kinstr\n | IEdiv_tez :\n Script.location * ((n num, Tez.t) pair option, 's, 'r, 'f) kinstr\n -> (Tez.t, Tez.t * 's, 'r, 'f) kinstr\n (*\n Booleans\n --------\n *)\n | IOr :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> (bool, bool * 's, 'r, 'f) kinstr\n | IAnd :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> (bool, bool * 's, 'r, 'f) kinstr\n | IXor :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> (bool, bool * 's, 'r, 'f) kinstr\n | INot :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> (bool, 's, 'r, 'f) kinstr\n (*\n Integers\n --------\n *)\n | IIs_nat :\n Script.location * (n num option, 's, 'r, 'f) kinstr\n -> (z num, 's, 'r, 'f) kinstr\n | INeg :\n Script.location * (z num, 's, 'r, 'f) kinstr\n -> ('a num, 's, 'r, 'f) kinstr\n | IAbs_int :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (z num, 's, 'r, 'f) kinstr\n | IInt_nat :\n Script.location * (z num, 's, 'r, 'f) kinstr\n -> (n num, 's, 'r, 'f) kinstr\n | IAdd_int :\n Script.location * (z num, 's, 'r, 'f) kinstr\n -> ('a num, 'b num * 's, 'r, 'f) kinstr\n | IAdd_nat :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (n num, n num * 's, 'r, 'f) kinstr\n | ISub_int :\n Script.location * (z num, 's, 'r, 'f) kinstr\n -> ('a num, 'b num * 's, 'r, 'f) kinstr\n | IMul_int :\n Script.location * (z num, 's, 'r, 'f) kinstr\n -> ('a num, 'b num * 's, 'r, 'f) kinstr\n | IMul_nat :\n Script.location * ('a num, 's, 'r, 'f) kinstr\n -> (n num, 'a num * 's, 'r, 'f) kinstr\n | IEdiv_int :\n Script.location * ((z num, n num) pair option, 's, 'r, 'f) kinstr\n -> ('a num, 'b num * 's, 'r, 'f) kinstr\n | IEdiv_nat :\n Script.location * (('a num, n num) pair option, 's, 'r, 'f) kinstr\n -> (n num, 'a num * 's, 'r, 'f) kinstr\n | ILsl_nat :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (n num, n num * 's, 'r, 'f) kinstr\n | ILsr_nat :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (n num, n num * 's, 'r, 'f) kinstr\n | IOr_nat :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (n num, n num * 's, 'r, 'f) kinstr\n | IAnd_nat :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (n num, n num * 's, 'r, 'f) kinstr\n | IAnd_int_nat :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (z num, n num * 's, 'r, 'f) kinstr\n | IXor_nat :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (n num, n num * 's, 'r, 'f) kinstr\n | INot_int :\n Script.location * (z num, 's, 'r, 'f) kinstr\n -> ('a num, 's, 'r, 'f) kinstr\n (*\n Control\n -------\n *)\n | IIf : {\n loc : Script.location;\n branch_if_true : ('a, 's, 'b, 'u) kinstr;\n branch_if_false : ('a, 's, 'b, 'u) kinstr;\n k : ('b, 'u, 'r, 'f) kinstr;\n }\n -> (bool, 'a * 's, 'r, 'f) kinstr\n | ILoop :\n Script.location * ('a, 's, bool, 'a * 's) kinstr * ('a, 's, 'r, 'f) kinstr\n -> (bool, 'a * 's, 'r, 'f) kinstr\n | ILoop_left :\n Script.location\n * ('a, 's, ('a, 'b) union, 's) kinstr\n * ('b, 's, 'r, 'f) kinstr\n -> (('a, 'b) union, 's, 'r, 'f) kinstr\n | IDip :\n Script.location\n * ('b, 's, 'c, 't) kinstr\n * ('a, _) ty option\n * ('a, 'c * 't, 'r, 'f) kinstr\n -> ('a, 'b * 's, 'r, 'f) kinstr\n | IExec :\n Script.location * ('b, 's) stack_ty option * ('b, 's, 'r, 'f) kinstr\n -> ('a, ('a, 'b) lambda * 's, 'r, 'f) kinstr\n | IApply :\n Script.location * ('a, _) ty * (('b, 'c) lambda, 's, 'r, 'f) kinstr\n -> ('a, ('a * 'b, 'c) lambda * 's, 'r, 'f) kinstr\n | ILambda :\n Script.location\n * ('b, 'c) lambda\n * (('b, 'c) lambda, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IFailwith : Script.location * ('a, _) ty -> ('a, 's, 'r, 'f) kinstr\n (*\n Comparison\n ----------\n *)\n | ICompare :\n Script.location * 'a comparable_ty * (z num, 'b * 's, 'r, 'f) kinstr\n -> ('a, 'a * ('b * 's), 'r, 'f) kinstr\n (*\n Comparators\n -----------\n *)\n | IEq :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> (z num, 's, 'r, 'f) kinstr\n | INeq :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> (z num, 's, 'r, 'f) kinstr\n | ILt :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> (z num, 's, 'r, 'f) kinstr\n | IGt :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> (z num, 's, 'r, 'f) kinstr\n | ILe :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> (z num, 's, 'r, 'f) kinstr\n | IGe :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> (z num, 's, 'r, 'f) kinstr\n (*\n Protocol\n --------\n *)\n | IAddress :\n Script.location * (address, 's, 'r, 'f) kinstr\n -> ('a typed_contract, 's, 'r, 'f) kinstr\n | IContract :\n Script.location\n * ('a, _) ty\n * Entrypoint.t\n * ('a typed_contract option, 's, 'r, 'f) kinstr\n -> (address, 's, 'r, 'f) kinstr\n | IView :\n Script.location\n * ('a, 'b) view_signature\n * ('c, 's) stack_ty option\n * ('b option, 'c * 's, 'r, 'f) kinstr\n -> ('a, address * ('c * 's), 'r, 'f) kinstr\n | ITransfer_tokens :\n Script.location * (operation, 's, 'r, 'f) kinstr\n -> ('a, Tez.t * ('a typed_contract * 's), 'r, 'f) kinstr\n | IImplicit_account :\n Script.location * (unit typed_contract, 's, 'r, 'f) kinstr\n -> (public_key_hash, 's, 'r, 'f) kinstr\n | ICreate_contract : {\n loc : Script.location;\n storage_type : ('a, _) ty;\n code : Script.expr;\n k : (operation, address * ('c * 's), 'r, 'f) kinstr;\n }\n -> (public_key_hash option, Tez.t * ('a * ('c * 's)), 'r, 'f) kinstr\n | ISet_delegate :\n Script.location * (operation, 's, 'r, 'f) kinstr\n -> (public_key_hash option, 's, 'r, 'f) kinstr\n | INow :\n Script.location * (Script_timestamp.t, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IMin_block_time :\n Script.location * (n num, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IBalance :\n Script.location * (Tez.t, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | ILevel :\n Script.location * (n num, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | ICheck_signature :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> (public_key, signature * (bytes * 's), 'r, 'f) kinstr\n | IHash_key :\n Script.location * (public_key_hash, 's, 'r, 'f) kinstr\n -> (public_key, 's, 'r, 'f) kinstr\n | IPack :\n Script.location * ('a, _) ty * (bytes, 'b * 's, 'r, 'f) kinstr\n -> ('a, 'b * 's, 'r, 'f) kinstr\n | IUnpack :\n Script.location * ('a, _) ty * ('a option, 's, 'r, 'f) kinstr\n -> (bytes, 's, 'r, 'f) kinstr\n | IBlake2b :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, 's, 'r, 'f) kinstr\n | ISha256 :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, 's, 'r, 'f) kinstr\n | ISha512 :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, 's, 'r, 'f) kinstr\n | ISource :\n Script.location * (address, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | ISender :\n Script.location * (address, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | ISelf :\n Script.location\n * ('b, _) ty\n * Entrypoint.t\n * ('b typed_contract, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | ISelf_address :\n Script.location * (address, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IAmount :\n Script.location * (Tez.t, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | ISapling_empty_state :\n Script.location\n * Sapling.Memo_size.t\n * (Sapling.state, 'a * 's, 'b, 'f) kinstr\n -> ('a, 's, 'b, 'f) kinstr\n | ISapling_verify_update :\n Script.location\n * ((bytes, (z num, Sapling.state) pair) pair option, 's, 'r, 'f) kinstr\n -> (Sapling.transaction, Sapling.state * 's, 'r, 'f) kinstr\n | ISapling_verify_update_deprecated :\n (* legacy introduced in J *)\n Script.location\n * ((z num, Sapling.state) pair option, 's, 'r, 'f) kinstr\n -> (Sapling.Legacy.transaction, Sapling.state * 's, 'r, 'f) kinstr\n | IDig :\n Script.location\n (*\n There is a prefix of length [n] common to the input stack\n of type ['a * 's] and an intermediary stack of type ['d * 'u].\n *)\n * int\n (*\n Under this common prefix, the input stack has type ['b * 'c * 't] and\n the intermediary stack type ['c * 't] because we removed the ['b] from\n the input stack. This value of type ['b] is pushed on top of the\n stack passed to the continuation.\n *)\n * ('b, 'c * 't, 'c, 't, 'a, 's, 'd, 'u) stack_prefix_preservation_witness\n * ('b, 'd * 'u, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IDug :\n Script.location\n (*\n The input stack has type ['a * 'b * 's].\n\n There is a prefix of length [n] common to its substack\n of type ['b * 's] and the output stack of type ['d * 'u].\n *)\n * int\n (*\n Under this common prefix, the first stack has type ['c * 't]\n and the second has type ['a * 'c * 't] because we have pushed\n the topmost element of this input stack under the common prefix.\n *)\n * ('c, 't, 'a, 'c * 't, 'b, 's, 'd, 'u) stack_prefix_preservation_witness\n * ('d, 'u, 'r, 'f) kinstr\n -> ('a, 'b * 's, 'r, 'f) kinstr\n | IDipn :\n Script.location\n (* The body of Dipn is applied under a prefix of size [n]... *)\n * int\n (*\n ... the relation between the types of the input and output stacks\n is characterized by the following witness.\n (See forthcoming comments about [stack_prefix_preservation_witness].)\n *)\n * ('c, 't, 'd, 'v, 'a, 's, 'b, 'u) stack_prefix_preservation_witness\n * ('c, 't, 'd, 'v) kinstr\n * ('b, 'u, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IDropn :\n Script.location\n (*\n The input stack enjoys a prefix of length [n]...\n *)\n * int\n (*\n ... and the following value witnesses that under this prefix\n the stack has type ['b * 'u].\n *)\n * ('b, 'u, 'b, 'u, 'a, 's, 'a, 's) stack_prefix_preservation_witness\n (*\n This stack is passed to the continuation since we drop the\n entire prefix.\n *)\n * ('b, 'u, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IChainId :\n Script.location * (Script_chain_id.t, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | INever : Script.location -> (never, 's, 'r, 'f) kinstr\n | IVoting_power :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (public_key_hash, 's, 'r, 'f) kinstr\n | ITotal_voting_power :\n Script.location * (n num, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IKeccak :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, 's, 'r, 'f) kinstr\n | ISha3 :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, 's, 'r, 'f) kinstr\n | IAdd_bls12_381_g1 :\n Script.location * (Script_bls.G1.t, 's, 'r, 'f) kinstr\n -> (Script_bls.G1.t, Script_bls.G1.t * 's, 'r, 'f) kinstr\n | IAdd_bls12_381_g2 :\n Script.location * (Script_bls.G2.t, 's, 'r, 'f) kinstr\n -> (Script_bls.G2.t, Script_bls.G2.t * 's, 'r, 'f) kinstr\n | IAdd_bls12_381_fr :\n Script.location * (Script_bls.Fr.t, 's, 'r, 'f) kinstr\n -> (Script_bls.Fr.t, Script_bls.Fr.t * 's, 'r, 'f) kinstr\n | IMul_bls12_381_g1 :\n Script.location * (Script_bls.G1.t, 's, 'r, 'f) kinstr\n -> (Script_bls.G1.t, Script_bls.Fr.t * 's, 'r, 'f) kinstr\n | IMul_bls12_381_g2 :\n Script.location * (Script_bls.G2.t, 's, 'r, 'f) kinstr\n -> (Script_bls.G2.t, Script_bls.Fr.t * 's, 'r, 'f) kinstr\n | IMul_bls12_381_fr :\n Script.location * (Script_bls.Fr.t, 's, 'r, 'f) kinstr\n -> (Script_bls.Fr.t, Script_bls.Fr.t * 's, 'r, 'f) kinstr\n | IMul_bls12_381_z_fr :\n Script.location * (Script_bls.Fr.t, 's, 'r, 'f) kinstr\n -> (Script_bls.Fr.t, 'a num * 's, 'r, 'f) kinstr\n | IMul_bls12_381_fr_z :\n Script.location * (Script_bls.Fr.t, 's, 'r, 'f) kinstr\n -> ('a num, Script_bls.Fr.t * 's, 'r, 'f) kinstr\n | IInt_bls12_381_fr :\n Script.location * (z num, 's, 'r, 'f) kinstr\n -> (Script_bls.Fr.t, 's, 'r, 'f) kinstr\n | INeg_bls12_381_g1 :\n Script.location * (Script_bls.G1.t, 's, 'r, 'f) kinstr\n -> (Script_bls.G1.t, 's, 'r, 'f) kinstr\n | INeg_bls12_381_g2 :\n Script.location * (Script_bls.G2.t, 's, 'r, 'f) kinstr\n -> (Script_bls.G2.t, 's, 'r, 'f) kinstr\n | INeg_bls12_381_fr :\n Script.location * (Script_bls.Fr.t, 's, 'r, 'f) kinstr\n -> (Script_bls.Fr.t, 's, 'r, 'f) kinstr\n | IPairing_check_bls12_381 :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> ( (Script_bls.G1.t, Script_bls.G2.t) pair Script_list.t,\n 's,\n 'r,\n 'f )\n kinstr\n | IComb :\n Script.location\n * int\n * ('a, 'b, 's, 'c, 'd, 't) comb_gadt_witness\n * ('c, 'd * 't, 'r, 'f) kinstr\n -> ('a, 'b * 's, 'r, 'f) kinstr\n | IUncomb :\n Script.location\n * int\n * ('a, 'b, 's, 'c, 'd, 't) uncomb_gadt_witness\n * ('c, 'd * 't, 'r, 'f) kinstr\n -> ('a, 'b * 's, 'r, 'f) kinstr\n | IComb_get :\n Script.location\n * int\n * ('t, 'v) comb_get_gadt_witness\n * ('v, 'a * 's, 'r, 'f) kinstr\n -> ('t, 'a * 's, 'r, 'f) kinstr\n | IComb_set :\n Script.location\n * int\n * ('a, 'b, 'c) comb_set_gadt_witness\n * ('c, 'd * 's, 'r, 'f) kinstr\n -> ('a, 'b * ('d * 's), 'r, 'f) kinstr\n | IDup_n :\n Script.location\n * int\n * ('a, 'b, 's, 't) dup_n_gadt_witness\n * ('t, 'a * ('b * 's), 'r, 'f) kinstr\n -> ('a, 'b * 's, 'r, 'f) kinstr\n | ITicket :\n Script.location\n * 'a comparable_ty option\n * ('a ticket option, 's, 'r, 'f) kinstr\n -> ('a, n num * 's, 'r, 'f) kinstr\n | ITicket_deprecated :\n Script.location * 'a comparable_ty option * ('a ticket, 's, 'r, 'f) kinstr\n -> ('a, n num * 's, 'r, 'f) kinstr\n | IRead_ticket :\n Script.location\n * 'a comparable_ty option\n * (address * ('a * n num), 'a ticket * 's, 'r, 'f) kinstr\n -> ('a ticket, 's, 'r, 'f) kinstr\n | ISplit_ticket :\n Script.location * (('a ticket * 'a ticket) option, 's, 'r, 'f) kinstr\n -> ('a ticket, (n num * n num) * 's, 'r, 'f) kinstr\n | IJoin_tickets :\n Script.location * 'a comparable_ty * ('a ticket option, 's, 'r, 'f) kinstr\n -> ('a ticket * 'a ticket, 's, 'r, 'f) kinstr\n | IOpen_chest :\n Script.location * ((bytes, bool) union, 's, 'r, 'f) kinstr\n -> ( Script_timelock.chest_key,\n Script_timelock.chest * (n num * 's),\n 'r,\n 'f )\n kinstr\n | IEmit : {\n loc : Script.location;\n tag : Entrypoint.t;\n ty : ('a, _) ty;\n unparsed_ty : Script.expr;\n k : (operation, 's, 'r, 'f) kinstr;\n }\n -> ('a, 's, 'r, 'f) kinstr\n (*\n\n Internal control instructions\n =============================\n\n The following instructions are not available in the source language.\n They are used by the internals of the interpreter.\n *)\n | IHalt : Script.location -> ('a, 's, 'a, 's) kinstr\n | ILog :\n Script.location\n * ('a, 's) stack_ty\n * logging_event\n * logger\n * ('a, 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n\nand ('arg, 'ret) lambda =\n | Lam :\n ('arg, end_of_stack, 'ret, end_of_stack) kdescr * Script.node\n -> ('arg, 'ret) lambda\n | LamRec :\n ('arg, ('arg, 'ret) lambda * end_of_stack, 'ret, end_of_stack) kdescr\n * Script.node\n -> ('arg, 'ret) lambda\n\nand 'arg typed_contract =\n | Typed_implicit : public_key_hash -> unit typed_contract\n | Typed_implicit_with_ticket : {\n ticket_ty : ('arg ticket, _) ty;\n destination : public_key_hash;\n }\n -> 'arg ticket typed_contract\n | Typed_originated : {\n arg_ty : ('arg, _) ty;\n contract_hash : Contract_hash.t;\n entrypoint : Entrypoint.t;\n }\n -> 'arg typed_contract\n | Typed_tx_rollup : {\n arg_ty : (('a ticket, tx_rollup_l2_address) pair, _) ty;\n tx_rollup : Tx_rollup.t;\n }\n -> ('a ticket, tx_rollup_l2_address) pair typed_contract\n | Typed_sc_rollup : {\n arg_ty : ('arg, _) ty;\n sc_rollup : Sc_rollup.t;\n entrypoint : Entrypoint.t;\n }\n -> 'arg typed_contract\n | Typed_zk_rollup : {\n arg_ty : (('a ticket, bytes) pair, _) ty;\n zk_rollup : Zk_rollup.t;\n }\n -> ('a ticket, bytes) pair typed_contract\n\n(*\n\n Control stack\n =============\n\n The control stack is a list of [kinstr].\n\n Since [kinstr] denotes a list of instructions, the control stack\n can be seen as a list of instruction sequences, each representing a\n form of delimited continuation (i.e. a control stack fragment). The\n [continuation] GADT ensures that the input and output stack types of the\n continuations are consistent.\n\n Loops have a special treatment because their control stack is reused\n as is for the next iteration. This avoids the reallocation of a\n control stack cell at each iteration.\n\n To implement [step] as a tail-recursive function, we implement\n higher-order iterators (i.e. MAPs and ITERs) using internal instructions\n. Roughly speaking, these instructions help in decomposing the execution\n of [I f c] (where [I] is an higher-order iterator over a container [c])\n into three phases: to start the iteration, to execute [f] if there are\n elements to be processed in [c], and to loop.\n\n Dip also has a dedicated constructor in the control stack. This\n allows the stack prefix to be restored after the execution of the\n [Dip]'s body.\n\n Following the same style as in [kinstr], [continuation] has four\n arguments, two for each stack types. More precisely, with\n\n [('bef_top, 'bef, 'aft_top, 'aft) continuation]\n\n we encode the fact that the stack before executing the continuation\n has type [('bef_top * 'bef)] and that the stack after this execution\n has type [('aft_top * 'aft)].\n\n*)\nand (_, _, _, _) continuation =\n (* This continuation returns immediately. *)\n | KNil : ('r, 'f, 'r, 'f) continuation\n (* This continuation starts with the next instruction to execute. *)\n | KCons :\n ('a, 's, 'b, 't) kinstr * ('b, 't, 'r, 'f) continuation\n -> ('a, 's, 'r, 'f) continuation\n (* This continuation represents a call frame: it stores the caller's\n stack of type ['s] and the continuation which expects the callee's\n result on top of the stack. *)\n | KReturn :\n 's * ('a, 's) stack_ty option * ('a, 's, 'r, 'f) continuation\n -> ('a, end_of_stack, 'r, 'f) continuation\n (* This continuation is useful when stack head requires some wrapping or\n unwrapping before it can be passed forward. For instance this continuation\n is used after a [MAP] instruction applied to an option in order to wrap the\n result back in a [Some] constructor.\n\n /!\\ When using it, make sure the function runs in constant time or that gas\n has been properly charged beforehand.\n Also make sure it runs with a small, bounded stack.\n *)\n | KMap_head :\n ('a -> 'b) * ('b, 's, 'r, 'f) continuation\n -> ('a, 's, 'r, 'f) continuation\n (* This continuation comes right after a [Dip i] to restore the topmost\n element ['b] of the stack after having executed [i] in the substack\n of type ['a * 's]. *)\n | KUndip :\n 'b * ('b, _) ty option * ('b, 'a * 's, 'r, 'f) continuation\n -> ('a, 's, 'r, 'f) continuation\n (* This continuation is executed at each iteration of a loop with\n a Boolean condition. *)\n | KLoop_in :\n ('a, 's, bool, 'a * 's) kinstr * ('a, 's, 'r, 'f) continuation\n -> (bool, 'a * 's, 'r, 'f) continuation\n (* This continuation is executed at each iteration of a loop with\n a condition encoded by a sum type. *)\n | KLoop_in_left :\n ('a, 's, ('a, 'b) union, 's) kinstr * ('b, 's, 'r, 'f) continuation\n -> (('a, 'b) union, 's, 'r, 'f) continuation\n (* This continuation is executed at each iteration of a traversal.\n (Used in List, Map and Set.) *)\n | KIter :\n ('a, 'b * 's, 'b, 's) kinstr\n * ('a, _) ty option\n * 'a list\n * ('b, 's, 'r, 'f) continuation\n -> ('b, 's, 'r, 'f) continuation\n (* This continuation represents each step of a List.map. *)\n | KList_enter_body :\n ('a, 'c * 's, 'b, 'c * 's) kinstr\n * 'a list\n * 'b Script_list.t\n * ('b Script_list.t, _) ty option\n * int\n * ('b Script_list.t, 'c * 's, 'r, 'f) continuation\n -> ('c, 's, 'r, 'f) continuation\n (* This continuation represents what is done after each step of a List.map. *)\n | KList_exit_body :\n ('a, 'c * 's, 'b, 'c * 's) kinstr\n * 'a list\n * 'b Script_list.t\n * ('b Script_list.t, _) ty option\n * int\n * ('b Script_list.t, 'c * 's, 'r, 'f) continuation\n -> ('b, 'c * 's, 'r, 'f) continuation\n (* This continuation represents each step of a Map.map. *)\n | KMap_enter_body :\n ('a * 'b, 'd * 's, 'c, 'd * 's) kinstr\n * ('a * 'b) list\n * ('a, 'c) map\n * (('a, 'c) map, _) ty option\n * (('a, 'c) map, 'd * 's, 'r, 'f) continuation\n -> ('d, 's, 'r, 'f) continuation\n (* This continuation represents what is done after each step of a Map.map. *)\n | KMap_exit_body :\n ('a * 'b, 'd * 's, 'c, 'd * 's) kinstr\n * ('a * 'b) list\n * ('a, 'c) map\n * 'a\n * (('a, 'c) map, _) ty option\n * (('a, 'c) map, 'd * 's, 'r, 'f) continuation\n -> ('c, 'd * 's, 'r, 'f) continuation\n (* This continuation represents what is done after returning from a view.\n It holds the original step constants value prior to entering the view. *)\n | KView_exit :\n step_constants * ('a, 's, 'r, 'f) continuation\n -> ('a, 's, 'r, 'f) continuation\n (* This continuation instruments the execution with a [logger]. *)\n | KLog :\n ('a, 's, 'r, 'f) continuation * ('a, 's) stack_ty * logger\n -> ('a, 's, 'r, 'f) continuation\n\n(*\n\n Execution instrumentation\n =========================\n\n One can observe the context and the stack at some specific points\n of an execution step. This feature is implemented by calling back\n some [logging_function]s defined in a record of type [logger]\n passed as argument to the step function.\n\n A [logger] is typically embedded in an [KLog] continuation by the\n client to trigger an evaluation instrumented with some logging. The\n logger is then automatically propagated to the logging instruction\n [ILog] as well as to any instructions that need to generate a\n backtrace when it fails (e.g., [IFailwith], [IMul_teznat], ...).\n\n*)\nand ('a, 's, 'b, 'f, 'c, 'u) logging_function =\n ('a, 's, 'b, 'f) kinstr ->\n context ->\n Script.location ->\n ('c, 'u) stack_ty ->\n 'c * 'u ->\n unit\n\nand execution_trace = (Script.location * Gas.Arith.fp * Script.expr list) list\n\nand logger = {\n log_interp : 'a 's 'b 'f 'c 'u. ('a, 's, 'b, 'f, 'c, 'u) logging_function;\n (** [log_interp] is called at each call of the internal function\n [interp]. [interp] is called when starting the interpretation of\n a script and subsequently at each [Exec] instruction. *)\n get_log : unit -> execution_trace option tzresult Lwt.t;\n (** [get_log] allows to obtain an execution trace, if any was\n produced. *)\n klog : 'a 's 'r 'f. ('a, 's, 'r, 'f) klog;\n (** [klog] is called on [KLog] inserted when instrumenting\n continuations. *)\n ilog : 'a 's 'b 't 'r 'f. ('a, 's, 'b, 't, 'r, 'f) ilog;\n (** [ilog] is called on [ILog] inserted when instrumenting\n instructions. *)\n log_kinstr : 'a 'b 'c 'd. ('a, 'b, 'c, 'd) log_kinstr;\n (** [log_kinstr] instruments an instruction with [ILog]. *)\n}\n\nand ('a, 's, 'r, 'f) klog =\n logger ->\n Local_gas_counter.outdated_context * step_constants ->\n Local_gas_counter.local_gas_counter ->\n ('a, 's) stack_ty ->\n ('a, 's, 'r, 'f) continuation ->\n ('a, 's, 'r, 'f) continuation ->\n 'a ->\n 's ->\n ('r\n * 'f\n * Local_gas_counter.outdated_context\n * Local_gas_counter.local_gas_counter)\n tzresult\n Lwt.t\n\nand ('a, 's, 'b, 't, 'r, 'f) ilog =\n logger ->\n logging_event ->\n ('a, 's) stack_ty ->\n ('a, 's, 'b, 't, 'r, 'f) step_type\n\nand ('a, 's, 'b, 't, 'r, 'f) step_type =\n Local_gas_counter.outdated_context * step_constants ->\n Local_gas_counter.local_gas_counter ->\n ('a, 's, 'b, 't) kinstr ->\n ('b, 't, 'r, 'f) continuation ->\n 'a ->\n 's ->\n ('r\n * 'f\n * Local_gas_counter.outdated_context\n * Local_gas_counter.local_gas_counter)\n tzresult\n Lwt.t\n\nand ('a, 'b, 'c, 'd) log_kinstr =\n logger ->\n ('a, 'b) stack_ty ->\n ('a, 'b, 'c, 'd) kinstr ->\n ('a, 'b, 'c, 'd) kinstr\n\n(* ---- Auxiliary types -----------------------------------------------------*)\nand ('ty, 'comparable) ty =\n | Unit_t : (unit, yes) ty\n | Int_t : (z num, yes) ty\n | Nat_t : (n num, yes) ty\n | Signature_t : (signature, yes) ty\n | String_t : (Script_string.t, yes) ty\n | Bytes_t : (bytes, yes) ty\n | Mutez_t : (Tez.t, yes) ty\n | Key_hash_t : (public_key_hash, yes) ty\n | Key_t : (public_key, yes) ty\n | Timestamp_t : (Script_timestamp.t, yes) ty\n | Address_t : (address, yes) ty\n | Tx_rollup_l2_address_t : (tx_rollup_l2_address, yes) ty\n | Bool_t : (bool, yes) ty\n | Pair_t :\n ('a, 'ac) ty\n * ('b, 'bc) ty\n * ('a, 'b) pair ty_metadata\n * ('ac, 'bc, 'rc) dand\n -> (('a, 'b) pair, 'rc) ty\n | Union_t :\n ('a, 'ac) ty\n * ('b, 'bc) ty\n * ('a, 'b) union ty_metadata\n * ('ac, 'bc, 'rc) dand\n -> (('a, 'b) union, 'rc) ty\n | Lambda_t :\n ('arg, _) ty * ('ret, _) ty * ('arg, 'ret) lambda ty_metadata\n -> (('arg, 'ret) lambda, no) ty\n | Option_t :\n ('v, 'c) ty * 'v option ty_metadata * 'c dbool\n -> ('v option, 'c) ty\n | List_t :\n ('v, _) ty * 'v Script_list.t ty_metadata\n -> ('v Script_list.t, no) ty\n | Set_t : 'v comparable_ty * 'v set ty_metadata -> ('v set, no) ty\n | Map_t :\n 'k comparable_ty * ('v, _) ty * ('k, 'v) map ty_metadata\n -> (('k, 'v) map, no) ty\n | Big_map_t :\n 'k comparable_ty * ('v, _) ty * ('k, 'v) big_map ty_metadata\n -> (('k, 'v) big_map, no) ty\n | Contract_t :\n ('arg, _) ty * 'arg typed_contract ty_metadata\n -> ('arg typed_contract, no) ty\n | Sapling_transaction_t : Sapling.Memo_size.t -> (Sapling.transaction, no) ty\n | Sapling_transaction_deprecated_t :\n Sapling.Memo_size.t\n -> (Sapling.Legacy.transaction, no) ty\n | Sapling_state_t : Sapling.Memo_size.t -> (Sapling.state, no) ty\n | Operation_t : (operation, no) ty\n | Chain_id_t : (Script_chain_id.t, yes) ty\n | Never_t : (never, yes) ty\n | Bls12_381_g1_t : (Script_bls.G1.t, no) ty\n | Bls12_381_g2_t : (Script_bls.G2.t, no) ty\n | Bls12_381_fr_t : (Script_bls.Fr.t, no) ty\n | Ticket_t : 'a comparable_ty * 'a ticket ty_metadata -> ('a ticket, no) ty\n | Chest_key_t : (Script_timelock.chest_key, no) ty\n | Chest_t : (Script_timelock.chest, no) ty\n\nand 'ty comparable_ty = ('ty, yes) ty\n\nand ('top_ty, 'resty) stack_ty =\n | Item_t :\n ('ty, _) ty * ('ty2, 'rest) stack_ty\n -> ('ty, 'ty2 * 'rest) stack_ty\n | Bot_t : (empty_cell, empty_cell) stack_ty\n\nand ('key, 'value) big_map =\n | Big_map : {\n id : Big_map.Id.t option;\n diff : ('key, 'value) big_map_overlay;\n key_type : 'key comparable_ty;\n value_type : ('value, _) ty;\n }\n -> ('key, 'value) big_map\n\nand ('a, 's, 'r, 'f) kdescr = {\n kloc : Script.location;\n kbef : ('a, 's) stack_ty;\n kaft : ('r, 'f) stack_ty;\n kinstr : ('a, 's, 'r, 'f) kinstr;\n}\n\n(*\n\n Several instructions work under an arbitrary deep stack prefix\n (e.g, IDipn, IDropn, etc). To convince the typechecker that\n these instructions are well-typed, we must provide a witness\n to statically characterize the relationship between the input\n and the output stacks. The inhabitants of the following GADT\n act as such witnesses.\n\n More precisely, a value [w] of type\n\n [(c, t, d, v, a, s, b, u) stack_prefix_preservation_witness]\n\n proves that there is a common prefix between an input stack\n of type [a * s] and an output stack of type [b * u]. This prefix\n is as deep as the number of [KPrefix] application in [w]. When\n used with an operation parameterized by a natural number [n]\n characterizing the depth at which the operation must be applied,\n [w] is the Peano encoding of [n].\n\n When this prefix is removed from the two stacks, the input stack\n has type [c * t] while the output stack has type [d * v].\n\n*)\nand (_, _, _, _, _, _, _, _) stack_prefix_preservation_witness =\n | KPrefix :\n Script.location\n * ('a, _) ty\n * ('c, 'v, 'd, 'w, 'x, 's, 'y, 'u) stack_prefix_preservation_witness\n -> ( 'c,\n 'v,\n 'd,\n 'w,\n 'a,\n 'x * 's,\n 'a,\n 'y * 'u )\n stack_prefix_preservation_witness\n | KRest : ('a, 's, 'b, 'u, 'a, 's, 'b, 'u) stack_prefix_preservation_witness\n\nand (_, _, _, _, _, _) comb_gadt_witness =\n | Comb_one : ('a, 'x, 'before, 'a, 'x, 'before) comb_gadt_witness\n | Comb_succ :\n ('b, 'c, 's, 'd, 'e, 't) comb_gadt_witness\n -> ('a, 'b, 'c * 's, 'a * 'd, 'e, 't) comb_gadt_witness\n\nand (_, _, _, _, _, _) uncomb_gadt_witness =\n | Uncomb_one : ('a, 'x, 'before, 'a, 'x, 'before) uncomb_gadt_witness\n | Uncomb_succ :\n ('b, 'c, 's, 'd, 'e, 't) uncomb_gadt_witness\n -> ('a * 'b, 'c, 's, 'a, 'd, 'e * 't) uncomb_gadt_witness\n\nand ('before, 'after) comb_get_gadt_witness =\n | Comb_get_zero : ('b, 'b) comb_get_gadt_witness\n | Comb_get_one : ('a * 'b, 'a) comb_get_gadt_witness\n | Comb_get_plus_two :\n ('before, 'after) comb_get_gadt_witness\n -> ('a * 'before, 'after) comb_get_gadt_witness\n\nand ('value, 'before, 'after) comb_set_gadt_witness =\n | Comb_set_zero : ('value, _, 'value) comb_set_gadt_witness\n | Comb_set_one : ('value, 'hd * 'tl, 'value * 'tl) comb_set_gadt_witness\n | Comb_set_plus_two :\n ('value, 'before, 'after) comb_set_gadt_witness\n -> ('value, 'a * 'before, 'a * 'after) comb_set_gadt_witness\n\n(*\n\n [dup_n_gadt_witness ('a, 'b, 's, 't)] ensures that there exists at least\n [n] elements in ['a, 'b, 's] and that the [n]-th element is of type\n ['t]. Here [n] follows Peano's encoding (0 and successor).\n Besides, [0] corresponds to the topmost element of ['s].\n\n This relational predicate is defined by induction on [n].\n\n*)\nand (_, _, _, _) dup_n_gadt_witness =\n | Dup_n_zero : ('a, _, _, 'a) dup_n_gadt_witness\n | Dup_n_succ :\n ('b, 'c, 'stack, 'd) dup_n_gadt_witness\n -> ('a, 'b, 'c * 'stack, 'd) dup_n_gadt_witness\n\nand ('input, 'output) view_signature =\n | View_signature : {\n name : Script_string.t;\n input_ty : ('input, _) ty;\n output_ty : ('output, _) ty;\n }\n -> ('input, 'output) view_signature\n\nand 'kind internal_operation_contents =\n | Transaction_to_implicit : {\n destination : Signature.Public_key_hash.t;\n amount : Tez.tez;\n }\n -> Kind.transaction internal_operation_contents\n | Transaction_to_implicit_with_ticket : {\n destination : Signature.Public_key_hash.t;\n ticket_ty : ('content ticket, _) ty;\n ticket : 'content ticket;\n unparsed_ticket : Script.lazy_expr;\n amount : Tez.tez;\n }\n -> Kind.transaction internal_operation_contents\n | Transaction_to_smart_contract : {\n (* The [unparsed_parameters] field may seem useless since we have\n access to a typed version of the field (with [parameters_ty] and\n [parameters]), but we keep it so that we do not have to unparse the\n typed version in order to produce the receipt\n ([Apply_internal_results.internal_operation_contents]). *)\n destination : Contract_hash.t;\n amount : Tez.tez;\n entrypoint : Entrypoint.t;\n location : Script.location;\n parameters_ty : ('a, _) ty;\n parameters : 'a;\n unparsed_parameters : Script.expr;\n }\n -> Kind.transaction internal_operation_contents\n | Transaction_to_tx_rollup : {\n destination : Tx_rollup.t;\n parameters_ty : (('a ticket, tx_rollup_l2_address) pair, _) ty;\n parameters : ('a ticket, tx_rollup_l2_address) pair;\n unparsed_parameters : Script.expr;\n }\n -> Kind.transaction internal_operation_contents\n | Transaction_to_sc_rollup : {\n destination : Sc_rollup.t;\n entrypoint : Entrypoint.t;\n parameters_ty : ('a, _) ty;\n parameters : 'a;\n unparsed_parameters : Script.expr;\n }\n -> Kind.transaction internal_operation_contents\n | Event : {\n ty : Script.expr;\n tag : Entrypoint.t;\n unparsed_data : Script.expr;\n }\n -> Kind.event internal_operation_contents\n | Transaction_to_zk_rollup : {\n destination : Zk_rollup.t;\n parameters_ty : (('a ticket, bytes) pair, _) ty;\n parameters : ('a ticket, bytes) pair;\n unparsed_parameters : Script.expr;\n }\n -> Kind.transaction internal_operation_contents\n | Origination : {\n delegate : Signature.Public_key_hash.t option;\n code : Script.expr;\n unparsed_storage : Script.expr;\n credit : Tez.tez;\n preorigination : Contract_hash.t;\n storage_type : ('storage, _) ty;\n storage : 'storage;\n }\n -> Kind.origination internal_operation_contents\n | Delegation :\n Signature.Public_key_hash.t option\n -> Kind.delegation internal_operation_contents\n\nand 'kind internal_operation = {\n source : Destination.t;\n operation : 'kind internal_operation_contents;\n nonce : int;\n}\n\nand packed_internal_operation =\n | Internal_operation : 'kind internal_operation -> packed_internal_operation\n[@@ocaml.unboxed]\n\nand operation = {\n piop : packed_internal_operation;\n lazy_storage_diff : Lazy_storage.diffs option;\n}\n\ntype ('arg, 'storage) script =\n | Script : {\n code :\n (('arg, 'storage) pair, (operation Script_list.t, 'storage) pair) lambda;\n arg_type : ('arg, _) ty;\n storage : 'storage;\n storage_type : ('storage, _) ty;\n views : view_map;\n entrypoints : 'arg entrypoints;\n code_size : Cache_memory_helpers.sint;\n }\n -> ('arg, 'storage) script\n\ntype ex_ty = Ex_ty : ('a, _) ty -> ex_ty\n\nval manager_kind : 'kind internal_operation_contents -> 'kind Kind.manager\n\nval kinstr_location : (_, _, _, _) kinstr -> Script.location\n\nval ty_size : ('a, _) ty -> 'a Type_size.t\n\nval is_comparable : ('v, 'c) ty -> 'c dbool\n\ntype 'v ty_ex_c = Ty_ex_c : ('v, _) ty -> 'v ty_ex_c [@@ocaml.unboxed]\n\nval unit_t : unit comparable_ty\n\nval int_t : z num comparable_ty\n\nval nat_t : n num comparable_ty\n\nval signature_t : signature comparable_ty\n\nval string_t : Script_string.t comparable_ty\n\nval bytes_t : Bytes.t comparable_ty\n\nval mutez_t : Tez.t comparable_ty\n\nval key_hash_t : public_key_hash comparable_ty\n\nval key_t : public_key comparable_ty\n\nval timestamp_t : Script_timestamp.t comparable_ty\n\nval address_t : address comparable_ty\n\nval tx_rollup_l2_address_t : tx_rollup_l2_address comparable_ty\n\nval bool_t : bool comparable_ty\n\nval pair_t :\n Script.location -> ('a, _) ty -> ('b, _) ty -> ('a, 'b) pair ty_ex_c tzresult\n\nval pair_3_t :\n Script.location ->\n ('a, _) ty ->\n ('b, _) ty ->\n ('c, _) ty ->\n ('a, ('b, 'c) pair) pair ty_ex_c tzresult\n\nval comparable_pair_t :\n Script.location ->\n 'a comparable_ty ->\n 'b comparable_ty ->\n ('a, 'b) pair comparable_ty tzresult\n\nval comparable_pair_3_t :\n Script.location ->\n 'a comparable_ty ->\n 'b comparable_ty ->\n 'c comparable_ty ->\n ('a, ('b, 'c) pair) pair comparable_ty tzresult\n\nval union_t :\n Script.location -> ('a, _) ty -> ('b, _) ty -> ('a, 'b) union ty_ex_c tzresult\n\nval comparable_union_t :\n Script.location ->\n 'a comparable_ty ->\n 'b comparable_ty ->\n ('a, 'b) union comparable_ty tzresult\n\nval union_bytes_bool_t : (Bytes.t, bool) union comparable_ty\n\nval lambda_t :\n Script.location ->\n ('arg, _) ty ->\n ('ret, _) ty ->\n (('arg, 'ret) lambda, no) ty tzresult\n\nval option_t : Script.location -> ('v, 'c) ty -> ('v option, 'c) ty tzresult\n\nval option_mutez_t : Tez.t option comparable_ty\n\nval option_string_t : Script_string.t option comparable_ty\n\nval option_bytes_t : Bytes.t option comparable_ty\n\nval option_nat_t : n num option comparable_ty\n\nval option_pair_nat_nat_t : (n num, n num) pair option comparable_ty\n\nval option_pair_nat_mutez_t : (n num, Tez.t) pair option comparable_ty\n\nval option_pair_mutez_mutez_t : (Tez.t, Tez.t) pair option comparable_ty\n\nval option_pair_int_nat_t : (z num, n num) pair option comparable_ty\n\nval list_t : Script.location -> ('v, _) ty -> ('v Script_list.t, no) ty tzresult\n\nval list_operation_t : (operation Script_list.t, no) ty\n\nval set_t : Script.location -> 'v comparable_ty -> ('v set, no) ty tzresult\n\nval map_t :\n Script.location ->\n 'k comparable_ty ->\n ('v, _) ty ->\n (('k, 'v) map, no) ty tzresult\n\nval big_map_t :\n Script.location ->\n 'k comparable_ty ->\n ('v, _) ty ->\n (('k, 'v) big_map, no) ty tzresult\n\nval contract_t :\n Script.location -> ('arg, _) ty -> ('arg typed_contract, no) ty tzresult\n\nval contract_unit_t : (unit typed_contract, no) ty\n\nval sapling_transaction_t :\n memo_size:Sapling.Memo_size.t -> (Sapling.transaction, no) ty\n\nval sapling_transaction_deprecated_t :\n memo_size:Sapling.Memo_size.t -> (Sapling.Legacy.transaction, no) ty\n\nval sapling_state_t : memo_size:Sapling.Memo_size.t -> (Sapling.state, no) ty\n\nval operation_t : (operation, no) ty\n\nval chain_id_t : Script_chain_id.t comparable_ty\n\nval never_t : never comparable_ty\n\nval bls12_381_g1_t : (Script_bls.G1.t, no) ty\n\nval bls12_381_g2_t : (Script_bls.G2.t, no) ty\n\nval bls12_381_fr_t : (Script_bls.Fr.t, no) ty\n\nval ticket_t :\n Script.location -> 'a comparable_ty -> ('a ticket, no) ty tzresult\n\nval chest_key_t : (Script_timelock.chest_key, no) ty\n\nval chest_t : (Script_timelock.chest, no) ty\n\n(**\n\n The following functions named `X_traverse` for X in\n [{ kinstr, ty, comparable_ty, value }] provide tail recursive top down\n traversals over the values of these types.\n\n The traversal goes through a value and rewrites an accumulator\n along the way starting from some [init]ial value for the\n accumulator.\n\n All these traversals follow the same recursion scheme: the\n user-provided function is first called on the toplevel value, then\n the traversal recurses on the direct subvalues of the same type.\n\n Hence, the user-provided function must only compute the\n contribution of the value on the accumulator minus the contribution\n of its subvalues of the same type.\n\n*)\ntype 'a kinstr_traverse = {\n apply : 'b 'u 'r 'f. 'a -> ('b, 'u, 'r, 'f) kinstr -> 'a;\n}\n\nval kinstr_traverse :\n ('a, 'b, 'c, 'd) kinstr -> 'ret -> 'ret kinstr_traverse -> 'ret\n\ntype 'a ty_traverse = {apply : 't 'tc. 'a -> ('t, 'tc) ty -> 'a}\n\nval ty_traverse : ('a, _) ty -> 'r -> 'r ty_traverse -> 'r\n\ntype 'accu stack_ty_traverse = {\n apply : 'ty 's. 'accu -> ('ty, 's) stack_ty -> 'accu;\n}\n\nval stack_ty_traverse : ('a, 's) stack_ty -> 'r -> 'r stack_ty_traverse -> 'r\n\ntype 'a value_traverse = {apply : 't 'tc. 'a -> ('t, 'tc) ty -> 't -> 'a}\n\nval value_traverse : ('t, _) ty -> 't -> 'r -> 'r value_traverse -> 'r\n\nval stack_top_ty : ('a, 'b * 's) stack_ty -> 'a ty_ex_c\n\nmodule Typed_contract : sig\n val destination : _ typed_contract -> Destination.t\n\n val arg_ty : 'a typed_contract -> 'a ty_ex_c\n\n val entrypoint : _ typed_contract -> Entrypoint.t\n\n module Internal_for_tests : sig\n (* This function doesn't guarantee that the contract is well-typed wrt its\n registered type at origination, it only guarantees that the type is\n plausible wrt to the destination kind. *)\n val typed_exn :\n ('a, _) ty -> Destination.t -> Entrypoint.t -> 'a typed_contract\n end\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 DaiLambda, Inc. <contact@dailambda,jp> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\nopen Script_int\nopen Dependent_bool\n\n(*\n\n The step function of the interpreter is parametrized by a bunch of values called the step constants.\n These values are indeed constants during the call of a smart contract with the notable exception of\n the IView instruction which modifies `source`, `self`, and `amount` and the KView_exit continuation\n which restores them.\n ======================\n\n*)\ntype step_constants = {\n source : Destination.t;\n (** The address calling this contract, as returned by SENDER. *)\n payer : Signature.public_key_hash;\n (** The address of the implicit account that initiated the chain of contract calls, as returned by SOURCE. *)\n self : Contract_hash.t;\n (** The address of the contract being executed, as returned by SELF and SELF_ADDRESS.\n Also used:\n - as ticketer in TICKET\n - as caller in VIEW, TRANSFER_TOKENS, and CREATE_CONTRACT *)\n amount : Tez.t;\n (** The amount of the current transaction, as returned by AMOUNT. *)\n balance : Tez.t; (** The balance of the contract as returned by BALANCE. *)\n chain_id : Chain_id.t;\n (** The chain id of the chain, as returned by CHAIN_ID. *)\n now : Script_timestamp.t;\n (** The earliest time at which the current block could have been timestamped, as returned by NOW. *)\n level : Script_int.n Script_int.num;\n (** The level of the current block, as returned by LEVEL. *)\n}\n\n(* Preliminary definitions. *)\n\ntype never = |\n\ntype address = {destination : Destination.t; entrypoint : Entrypoint.t}\n\nmodule Script_signature = struct\n type t = Signature_tag of signature [@@ocaml.unboxed]\n\n let make s = Signature_tag s\n\n let get (Signature_tag s) = s\n\n let encoding =\n Data_encoding.conv\n (fun (Signature_tag x) -> x)\n (fun x -> Signature_tag x)\n Signature.encoding\n\n let of_b58check_opt x = Option.map make (Signature.of_b58check_opt x)\n\n let check ?watermark pub_key (Signature_tag s) bytes =\n Signature.check ?watermark pub_key s bytes\n\n let compare (Signature_tag x) (Signature_tag y) = Signature.compare x y\n\n let size (Signature_tag s) = Signature.size s\nend\n\ntype signature = Script_signature.t\n\n(* TODO: https://gitlab.com/tezos/tezos/-/issues/2466\n The various attributes of this type should be checked with\n appropriate testing. *)\ntype tx_rollup_l2_address = Tx_rollup_l2_address.Indexable.value\n\ntype ('a, 'b) pair = 'a * 'b\n\ntype ('a, 'b) union = L of 'a | R of 'b\n\nmodule Script_chain_id = struct\n type t = Chain_id_tag of Chain_id.t [@@ocaml.unboxed]\n\n let make x = Chain_id_tag x\n\n let compare (Chain_id_tag x) (Chain_id_tag y) = Chain_id.compare x y\n\n let size = Chain_id.size\n\n let encoding =\n Data_encoding.conv (fun (Chain_id_tag x) -> x) make Chain_id.encoding\n\n let to_b58check (Chain_id_tag x) = Chain_id.to_b58check x\n\n let of_b58check_opt x = Option.map make (Chain_id.of_b58check_opt x)\nend\n\nmodule Script_bls = struct\n module type S = sig\n type t\n\n type fr\n\n val add : t -> t -> t\n\n val mul : t -> fr -> t\n\n val negate : t -> t\n\n val of_bytes_opt : Bytes.t -> t option\n\n val to_bytes : t -> Bytes.t\n end\n\n module Fr = struct\n type t = Fr_tag of Bls.Primitive.Fr.t [@@ocaml.unboxed]\n\n open Bls.Primitive.Fr\n\n let add (Fr_tag x) (Fr_tag y) = Fr_tag (add x y)\n\n let mul (Fr_tag x) (Fr_tag y) = Fr_tag (mul x y)\n\n let negate (Fr_tag x) = Fr_tag (negate x)\n\n let of_bytes_opt bytes = Option.map (fun x -> Fr_tag x) (of_bytes_opt bytes)\n\n let to_bytes (Fr_tag x) = to_bytes x\n\n let of_z z = Fr_tag (of_z z)\n\n let to_z (Fr_tag x) = to_z x\n end\n\n module G1 = struct\n type t = G1_tag of Bls.Primitive.G1.t [@@ocaml.unboxed]\n\n open Bls.Primitive.G1\n\n let add (G1_tag x) (G1_tag y) = G1_tag (add x y)\n\n let mul (G1_tag x) (Fr.Fr_tag y) = G1_tag (mul x y)\n\n let negate (G1_tag x) = G1_tag (negate x)\n\n let of_bytes_opt bytes = Option.map (fun x -> G1_tag x) (of_bytes_opt bytes)\n\n let to_bytes (G1_tag x) = to_bytes x\n end\n\n module G2 = struct\n type t = G2_tag of Bls.Primitive.G2.t [@@ocaml.unboxed]\n\n open Bls.Primitive.G2\n\n let add (G2_tag x) (G2_tag y) = G2_tag (add x y)\n\n let mul (G2_tag x) (Fr.Fr_tag y) = G2_tag (mul x y)\n\n let negate (G2_tag x) = G2_tag (negate x)\n\n let of_bytes_opt bytes = Option.map (fun x -> G2_tag x) (of_bytes_opt bytes)\n\n let to_bytes (G2_tag x) = to_bytes x\n end\n\n let pairing_check l =\n let l = List.map (fun (G1.G1_tag x, G2.G2_tag y) -> (x, y)) l in\n Bls.Primitive.pairing_check l\nend\n\nmodule Script_timelock = struct\n type chest_key = Chest_key_tag of Timelock.chest_key [@@ocaml.unboxed]\n\n let make_chest_key chest_key = Chest_key_tag chest_key\n\n let chest_key_encoding =\n Data_encoding.conv\n (fun (Chest_key_tag x) -> x)\n (fun x -> Chest_key_tag x)\n Timelock.chest_key_encoding\n\n type chest = Chest_tag of Timelock.chest [@@ocaml.unboxed]\n\n let make_chest chest = Chest_tag chest\n\n let chest_encoding =\n Data_encoding.conv\n (fun (Chest_tag x) -> x)\n (fun x -> Chest_tag x)\n Timelock.chest_encoding\n\n let open_chest (Chest_tag chest) (Chest_key_tag chest_key) ~time =\n Timelock.open_chest chest chest_key ~time\n\n let get_plaintext_size (Chest_tag x) = Timelock.get_plaintext_size x\nend\n\ntype ticket_amount = Ticket_amount.t\n\ntype 'a ticket = {ticketer : Contract.t; contents : 'a; amount : ticket_amount}\n\nmodule type TYPE_SIZE = sig\n (* A type size represents the size of its type parameter.\n This constraint is enforced inside this module (Script_typed_ir), hence there\n should be no way to construct a type size outside of it.\n\n It allows keeping type metadata and types non-private.\n\n The size of a type is the number of nodes in its AST\n representation. In other words, the size of a type is 1 plus the size of\n its arguments. For instance, the size of [Unit] is 1 and the size of\n [Pair ty1 ty2] is [1] plus the size of [ty1] and [ty2].\n\n This module is here because we want three levels of visibility over this\n code:\n - inside this submodule, we have [type 'a t = int]\n - outside of [Script_typed_ir], the ['a t] type is abstract and we have\n the invariant that whenever [x : 'a t] we have that [x] is exactly\n the size of ['a].\n - in-between (inside [Script_typed_ir] but outside the [Type_size]\n submodule), the type is abstract but we have access to unsafe\n constructors that can break the invariant.\n *)\n type 'a t\n\n val check_eq :\n error_details:('error_context, 'error_trace) Script_tc_errors.error_details ->\n 'a t ->\n 'b t ->\n (unit, 'error_trace) result\n\n val to_int : 'a t -> Saturation_repr.mul_safe Saturation_repr.t\n\n (* Unsafe constructors, to be used only safely and inside this module *)\n\n val one : _ t\n\n val two : _ t\n\n val three : _ t\n\n val four : (_, _) pair option t\n\n val compound1 : Script.location -> _ t -> _ t tzresult\n\n val compound2 : Script.location -> _ t -> _ t -> _ t tzresult\nend\n\nmodule Type_size : TYPE_SIZE = struct\n type 'a t = int\n\n let () =\n (* static-like check that all [t] values fit in a [mul_safe] *)\n let (_ : Saturation_repr.mul_safe Saturation_repr.t) =\n Saturation_repr.mul_safe_of_int_exn Constants.michelson_maximum_type_size\n in\n ()\n\n let to_int = Saturation_repr.mul_safe_of_int_exn\n\n let one = 1\n\n let two = 2\n\n let three = 3\n\n let four = 4\n\n let check_eq :\n type a b error_trace.\n error_details:(_, error_trace) Script_tc_errors.error_details ->\n a t ->\n b t ->\n (unit, error_trace) result =\n fun ~error_details x y ->\n if Compare.Int.(x = y) then Result.return_unit\n else\n Error\n (match error_details with\n | Fast -> Inconsistent_types_fast\n | Informative _ ->\n trace_of_error @@ Script_tc_errors.Inconsistent_type_sizes (x, y))\n\n let of_int loc size =\n let max_size = Constants.michelson_maximum_type_size in\n if Compare.Int.(size <= max_size) then ok size\n else error (Script_tc_errors.Type_too_large (loc, max_size))\n\n let compound1 loc size = of_int loc (1 + size)\n\n let compound2 loc size1 size2 = of_int loc (1 + size1 + size2)\nend\n\ntype empty_cell = EmptyCell\n\ntype end_of_stack = empty_cell * empty_cell\n\ntype 'a ty_metadata = {size : 'a Type_size.t} [@@unboxed]\n\n(*\n\n This signature contains the exact set of functions used in the\n protocol. We do not include all [Set.S] because this would\n increase the size of the first class modules used to represent\n [boxed_set].\n\n Warning: for any change in this signature, there must be a\n change in [Script_typed_ir_size.value_size] which updates\n [boxing_space] in the case for sets.\n\n*)\nmodule type Boxed_set_OPS = sig\n type t\n\n type elt\n\n val elt_size : elt -> int (* Gas_input_size.t *)\n\n val empty : t\n\n val add : elt -> t -> t\n\n val mem : elt -> t -> bool\n\n val remove : elt -> t -> t\n\n val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a\nend\n\nmodule type Boxed_set = sig\n type elt\n\n module OPS : Boxed_set_OPS with type elt = elt\n\n val boxed : OPS.t\n\n val size : int\nend\n\ntype 'elt set = Set_tag of (module Boxed_set with type elt = 'elt)\n[@@ocaml.unboxed]\n\n(*\n\n Same remark as for [Boxed_set_OPS]. (See below.)\n\n*)\nmodule type Boxed_map_OPS = sig\n type 'a t\n\n type key\n\n val key_size : key -> int (* Gas_input_size.t *)\n\n val empty : 'value t\n\n val add : key -> 'value -> 'value t -> 'value t\n\n val remove : key -> 'value t -> 'value t\n\n val find : key -> 'value t -> 'value option\n\n val fold : (key -> 'value -> 'a -> 'a) -> 'value t -> 'a -> 'a\n\n val fold_es :\n (key -> 'value -> 'a -> 'a tzresult Lwt.t) ->\n 'value t ->\n 'a ->\n 'a tzresult Lwt.t\nend\n\nmodule type Boxed_map = sig\n type key\n\n type value\n\n module OPS : Boxed_map_OPS with type key = key\n\n val boxed : value OPS.t\n\n val size : int\nend\n\ntype ('key, 'value) map =\n | Map_tag of (module Boxed_map with type key = 'key and type value = 'value)\n[@@ocaml.unboxed]\n\nmodule Big_map_overlay = Map.Make (struct\n type t = Script_expr_hash.t\n\n let compare = Script_expr_hash.compare\nend)\n\ntype ('key, 'value) big_map_overlay = {\n map : ('key * 'value option) Big_map_overlay.t;\n size : int;\n}\n\ntype view = {\n input_ty : Script.node;\n output_ty : Script.node;\n view_code : Script.node;\n}\n\ntype view_map = (Script_string.t, view) map\n\ntype entrypoint_info = {name : Entrypoint.t; original_type_expr : Script.node}\n\ntype 'arg entrypoints_node = {\n at_node : entrypoint_info option;\n nested : 'arg nested_entrypoints;\n}\n\nand 'arg nested_entrypoints =\n | Entrypoints_Union : {\n left : 'l entrypoints_node;\n right : 'r entrypoints_node;\n }\n -> ('l, 'r) union nested_entrypoints\n | Entrypoints_None : _ nested_entrypoints\n\nlet no_entrypoints = {at_node = None; nested = Entrypoints_None}\n\ntype logging_event = LogEntry | LogExit of Script.location\n\ntype 'arg entrypoints = {\n root : 'arg entrypoints_node;\n original_type_expr : Script.node;\n}\n\n(* ---- Instructions --------------------------------------------------------*)\nand ('before_top, 'before, 'result_top, 'result) kinstr =\n (*\n Stack\n -----\n *)\n | IDrop :\n Script.location * ('b, 's, 'r, 'f) kinstr\n -> ('a, 'b * 's, 'r, 'f) kinstr\n | IDup :\n Script.location * ('a, 'a * ('b * 's), 'r, 'f) kinstr\n -> ('a, 'b * 's, 'r, 'f) kinstr\n | ISwap :\n Script.location * ('b, 'a * ('c * 's), 'r, 'f) kinstr\n -> ('a, 'b * ('c * 's), 'r, 'f) kinstr\n | IConst :\n Script.location * ('ty, _) ty * 'ty * ('ty, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n (*\n Pairs\n -----\n *)\n | ICons_pair :\n Script.location * ('a * 'b, 'c * 's, 'r, 'f) kinstr\n -> ('a, 'b * ('c * 's), 'r, 'f) kinstr\n | ICar :\n Script.location * ('a, 's, 'r, 'f) kinstr\n -> ('a * 'b, 's, 'r, 'f) kinstr\n | ICdr :\n Script.location * ('b, 's, 'r, 'f) kinstr\n -> ('a * 'b, 's, 'r, 'f) kinstr\n | IUnpair :\n Script.location * ('a, 'b * 's, 'r, 'f) kinstr\n -> ('a * 'b, 's, 'r, 'f) kinstr\n (*\n Options\n -------\n *)\n | ICons_some :\n Script.location * ('v option, 'a * 's, 'r, 'f) kinstr\n -> ('v, 'a * 's, 'r, 'f) kinstr\n | ICons_none :\n Script.location * ('b, _) ty * ('b option, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IIf_none : {\n loc : Script.location;\n branch_if_none : ('b, 's, 'c, 't) kinstr;\n branch_if_some : ('a, 'b * 's, 'c, 't) kinstr;\n k : ('c, 't, 'r, 'f) kinstr;\n }\n -> ('a option, 'b * 's, 'r, 'f) kinstr\n | IOpt_map : {\n loc : Script.location;\n body : ('a, 's, 'b, 's) kinstr;\n k : ('b option, 's, 'c, 't) kinstr;\n }\n -> ('a option, 's, 'c, 't) kinstr\n (*\n Unions\n ------\n *)\n | ICons_left :\n Script.location * ('b, _) ty * (('a, 'b) union, 'c * 's, 'r, 'f) kinstr\n -> ('a, 'c * 's, 'r, 'f) kinstr\n | ICons_right :\n Script.location * ('a, _) ty * (('a, 'b) union, 'c * 's, 'r, 'f) kinstr\n -> ('b, 'c * 's, 'r, 'f) kinstr\n | IIf_left : {\n loc : Script.location;\n branch_if_left : ('a, 's, 'c, 't) kinstr;\n branch_if_right : ('b, 's, 'c, 't) kinstr;\n k : ('c, 't, 'r, 'f) kinstr;\n }\n -> (('a, 'b) union, 's, 'r, 'f) kinstr\n (*\n Lists\n -----\n *)\n | ICons_list :\n Script.location * ('a Script_list.t, 's, 'r, 'f) kinstr\n -> ('a, 'a Script_list.t * 's, 'r, 'f) kinstr\n | INil :\n Script.location * ('b, _) ty * ('b Script_list.t, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IIf_cons : {\n loc : Script.location;\n branch_if_cons : ('a, 'a Script_list.t * ('b * 's), 'c, 't) kinstr;\n branch_if_nil : ('b, 's, 'c, 't) kinstr;\n k : ('c, 't, 'r, 'f) kinstr;\n }\n -> ('a Script_list.t, 'b * 's, 'r, 'f) kinstr\n | IList_map :\n Script.location\n * ('a, 'c * 's, 'b, 'c * 's) kinstr\n * ('b Script_list.t, _) ty option\n * ('b Script_list.t, 'c * 's, 'r, 'f) kinstr\n -> ('a Script_list.t, 'c * 's, 'r, 'f) kinstr\n | IList_iter :\n Script.location\n * ('a, _) ty option\n * ('a, 'b * 's, 'b, 's) kinstr\n * ('b, 's, 'r, 'f) kinstr\n -> ('a Script_list.t, 'b * 's, 'r, 'f) kinstr\n | IList_size :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> ('a Script_list.t, 's, 'r, 'f) kinstr\n (*\n Sets\n ----\n *)\n | IEmpty_set :\n Script.location * 'b comparable_ty * ('b set, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | ISet_iter :\n Script.location\n * 'a comparable_ty option\n * ('a, 'b * 's, 'b, 's) kinstr\n * ('b, 's, 'r, 'f) kinstr\n -> ('a set, 'b * 's, 'r, 'f) kinstr\n | ISet_mem :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> ('a, 'a set * 's, 'r, 'f) kinstr\n | ISet_update :\n Script.location * ('a set, 's, 'r, 'f) kinstr\n -> ('a, bool * ('a set * 's), 'r, 'f) kinstr\n | ISet_size :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> ('a set, 's, 'r, 'f) kinstr\n (*\n Maps\n ----\n *)\n | IEmpty_map :\n Script.location\n * 'b comparable_ty\n * ('c, _) ty option\n * (('b, 'c) map, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IMap_map :\n Script.location\n * (('a, 'c) map, _) ty option\n * ('a * 'b, 'd * 's, 'c, 'd * 's) kinstr\n * (('a, 'c) map, 'd * 's, 'r, 'f) kinstr\n -> (('a, 'b) map, 'd * 's, 'r, 'f) kinstr\n | IMap_iter :\n Script.location\n * ('a * 'b, _) ty option\n * ('a * 'b, 'c * 's, 'c, 's) kinstr\n * ('c, 's, 'r, 'f) kinstr\n -> (('a, 'b) map, 'c * 's, 'r, 'f) kinstr\n | IMap_mem :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> ('a, ('a, 'b) map * 's, 'r, 'f) kinstr\n | IMap_get :\n Script.location * ('b option, 's, 'r, 'f) kinstr\n -> ('a, ('a, 'b) map * 's, 'r, 'f) kinstr\n | IMap_update :\n Script.location * (('a, 'b) map, 's, 'r, 'f) kinstr\n -> ('a, 'b option * (('a, 'b) map * 's), 'r, 'f) kinstr\n | IMap_get_and_update :\n Script.location * ('b option, ('a, 'b) map * 's, 'r, 'f) kinstr\n -> ('a, 'b option * (('a, 'b) map * 's), 'r, 'f) kinstr\n | IMap_size :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (('a, 'b) map, 's, 'r, 'f) kinstr\n (*\n Big maps\n --------\n *)\n | IEmpty_big_map :\n Script.location\n * 'b comparable_ty\n * ('c, _) ty\n * (('b, 'c) big_map, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IBig_map_mem :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> ('a, ('a, 'b) big_map * 's, 'r, 'f) kinstr\n | IBig_map_get :\n Script.location * ('b option, 's, 'r, 'f) kinstr\n -> ('a, ('a, 'b) big_map * 's, 'r, 'f) kinstr\n | IBig_map_update :\n Script.location * (('a, 'b) big_map, 's, 'r, 'f) kinstr\n -> ('a, 'b option * (('a, 'b) big_map * 's), 'r, 'f) kinstr\n | IBig_map_get_and_update :\n Script.location * ('b option, ('a, 'b) big_map * 's, 'r, 'f) kinstr\n -> ('a, 'b option * (('a, 'b) big_map * 's), 'r, 'f) kinstr\n (*\n Strings\n -------\n *)\n | IConcat_string :\n Script.location * (Script_string.t, 's, 'r, 'f) kinstr\n -> (Script_string.t Script_list.t, 's, 'r, 'f) kinstr\n | IConcat_string_pair :\n Script.location * (Script_string.t, 's, 'r, 'f) kinstr\n -> (Script_string.t, Script_string.t * 's, 'r, 'f) kinstr\n | ISlice_string :\n Script.location * (Script_string.t option, 's, 'r, 'f) kinstr\n -> (n num, n num * (Script_string.t * 's), 'r, 'f) kinstr\n | IString_size :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (Script_string.t, 's, 'r, 'f) kinstr\n (*\n Bytes\n -----\n *)\n | IConcat_bytes :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes Script_list.t, 's, 'r, 'f) kinstr\n | IConcat_bytes_pair :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, bytes * 's, 'r, 'f) kinstr\n | ISlice_bytes :\n Script.location * (bytes option, 's, 'r, 'f) kinstr\n -> (n num, n num * (bytes * 's), 'r, 'f) kinstr\n | IBytes_size :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (bytes, 's, 'r, 'f) kinstr\n | ILsl_bytes :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, n num * 's, 'r, 'f) kinstr\n | ILsr_bytes :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, n num * 's, 'r, 'f) kinstr\n | IOr_bytes :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, bytes * 's, 'r, 'f) kinstr\n | IAnd_bytes :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, bytes * 's, 'r, 'f) kinstr\n | IXor_bytes :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, bytes * 's, 'r, 'f) kinstr\n | INot_bytes :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, 's, 'r, 'f) kinstr\n | INat_bytes :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (bytes, 's, 'r, 'f) kinstr\n | IBytes_nat :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (n num, 's, 'r, 'f) kinstr\n | IInt_bytes :\n Script.location * (z num, 's, 'r, 'f) kinstr\n -> (bytes, 's, 'r, 'f) kinstr\n | IBytes_int :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (z num, 's, 'r, 'f) kinstr\n (*\n Timestamps\n ----------\n *)\n | IAdd_seconds_to_timestamp :\n Script.location * (Script_timestamp.t, 's, 'r, 'f) kinstr\n -> (z num, Script_timestamp.t * 's, 'r, 'f) kinstr\n | IAdd_timestamp_to_seconds :\n Script.location * (Script_timestamp.t, 's, 'r, 'f) kinstr\n -> (Script_timestamp.t, z num * 's, 'r, 'f) kinstr\n | ISub_timestamp_seconds :\n Script.location * (Script_timestamp.t, 's, 'r, 'f) kinstr\n -> (Script_timestamp.t, z num * 's, 'r, 'f) kinstr\n | IDiff_timestamps :\n Script.location * (z num, 's, 'r, 'f) kinstr\n -> (Script_timestamp.t, Script_timestamp.t * 's, 'r, 'f) kinstr\n (*\n Tez\n ---\n *)\n | IAdd_tez :\n Script.location * (Tez.t, 's, 'r, 'f) kinstr\n -> (Tez.t, Tez.t * 's, 'r, 'f) kinstr\n | ISub_tez :\n Script.location * (Tez.t option, 's, 'r, 'f) kinstr\n -> (Tez.t, Tez.t * 's, 'r, 'f) kinstr\n | ISub_tez_legacy :\n Script.location * (Tez.t, 's, 'r, 'f) kinstr\n -> (Tez.t, Tez.t * 's, 'r, 'f) kinstr\n | IMul_teznat :\n Script.location * (Tez.t, 's, 'r, 'f) kinstr\n -> (Tez.t, n num * 's, 'r, 'f) kinstr\n | IMul_nattez :\n Script.location * (Tez.t, 's, 'r, 'f) kinstr\n -> (n num, Tez.t * 's, 'r, 'f) kinstr\n | IEdiv_teznat :\n Script.location * ((Tez.t, Tez.t) pair option, 's, 'r, 'f) kinstr\n -> (Tez.t, n num * 's, 'r, 'f) kinstr\n | IEdiv_tez :\n Script.location * ((n num, Tez.t) pair option, 's, 'r, 'f) kinstr\n -> (Tez.t, Tez.t * 's, 'r, 'f) kinstr\n (*\n Booleans\n --------\n *)\n | IOr :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> (bool, bool * 's, 'r, 'f) kinstr\n | IAnd :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> (bool, bool * 's, 'r, 'f) kinstr\n | IXor :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> (bool, bool * 's, 'r, 'f) kinstr\n | INot :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> (bool, 's, 'r, 'f) kinstr\n (*\n Integers\n --------\n *)\n | IIs_nat :\n Script.location * (n num option, 's, 'r, 'f) kinstr\n -> (z num, 's, 'r, 'f) kinstr\n | INeg :\n Script.location * (z num, 's, 'r, 'f) kinstr\n -> ('a num, 's, 'r, 'f) kinstr\n | IAbs_int :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (z num, 's, 'r, 'f) kinstr\n | IInt_nat :\n Script.location * (z num, 's, 'r, 'f) kinstr\n -> (n num, 's, 'r, 'f) kinstr\n | IAdd_int :\n Script.location * (z num, 's, 'r, 'f) kinstr\n -> ('a num, 'b num * 's, 'r, 'f) kinstr\n | IAdd_nat :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (n num, n num * 's, 'r, 'f) kinstr\n | ISub_int :\n Script.location * (z num, 's, 'r, 'f) kinstr\n -> ('a num, 'b num * 's, 'r, 'f) kinstr\n | IMul_int :\n Script.location * (z num, 's, 'r, 'f) kinstr\n -> ('a num, 'b num * 's, 'r, 'f) kinstr\n | IMul_nat :\n Script.location * ('a num, 's, 'r, 'f) kinstr\n -> (n num, 'a num * 's, 'r, 'f) kinstr\n | IEdiv_int :\n Script.location * ((z num, n num) pair option, 's, 'r, 'f) kinstr\n -> ('a num, 'b num * 's, 'r, 'f) kinstr\n | IEdiv_nat :\n Script.location * (('a num, n num) pair option, 's, 'r, 'f) kinstr\n -> (n num, 'a num * 's, 'r, 'f) kinstr\n | ILsl_nat :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (n num, n num * 's, 'r, 'f) kinstr\n | ILsr_nat :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (n num, n num * 's, 'r, 'f) kinstr\n | IOr_nat :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (n num, n num * 's, 'r, 'f) kinstr\n (* Even though `IAnd_nat` and `IAnd_int_nat` could be merged into a single\n instruction from both the type and behavior point of views, their gas costs\n differ too much (see `cost_N_IAnd_nat` and `cost_N_IAnd_int_nat` in\n `Michelson_v1_gas.Cost_of.Generated_costs`), so we keep them separated. *)\n | IAnd_nat :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (n num, n num * 's, 'r, 'f) kinstr\n | IAnd_int_nat :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (z num, n num * 's, 'r, 'f) kinstr\n | IXor_nat :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (n num, n num * 's, 'r, 'f) kinstr\n | INot_int :\n Script.location * (z num, 's, 'r, 'f) kinstr\n -> ('a num, 's, 'r, 'f) kinstr\n (*\n Control\n -------\n *)\n | IIf : {\n loc : Script.location;\n branch_if_true : ('a, 's, 'b, 'u) kinstr;\n branch_if_false : ('a, 's, 'b, 'u) kinstr;\n k : ('b, 'u, 'r, 'f) kinstr;\n }\n -> (bool, 'a * 's, 'r, 'f) kinstr\n | ILoop :\n Script.location * ('a, 's, bool, 'a * 's) kinstr * ('a, 's, 'r, 'f) kinstr\n -> (bool, 'a * 's, 'r, 'f) kinstr\n | ILoop_left :\n Script.location\n * ('a, 's, ('a, 'b) union, 's) kinstr\n * ('b, 's, 'r, 'f) kinstr\n -> (('a, 'b) union, 's, 'r, 'f) kinstr\n | IDip :\n Script.location\n * ('b, 's, 'c, 't) kinstr\n * ('a, _) ty option\n * ('a, 'c * 't, 'r, 'f) kinstr\n -> ('a, 'b * 's, 'r, 'f) kinstr\n | IExec :\n Script.location * ('b, 's) stack_ty option * ('b, 's, 'r, 'f) kinstr\n -> ('a, ('a, 'b) lambda * 's, 'r, 'f) kinstr\n | IApply :\n Script.location * ('a, _) ty * (('b, 'c) lambda, 's, 'r, 'f) kinstr\n -> ('a, ('a * 'b, 'c) lambda * 's, 'r, 'f) kinstr\n | ILambda :\n Script.location\n * ('b, 'c) lambda\n * (('b, 'c) lambda, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IFailwith : Script.location * ('a, _) ty -> ('a, 's, 'r, 'f) kinstr\n (*\n Comparison\n ----------\n *)\n | ICompare :\n Script.location * 'a comparable_ty * (z num, 'b * 's, 'r, 'f) kinstr\n -> ('a, 'a * ('b * 's), 'r, 'f) kinstr\n (*\n Comparators\n -----------\n *)\n | IEq :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> (z num, 's, 'r, 'f) kinstr\n | INeq :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> (z num, 's, 'r, 'f) kinstr\n | ILt :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> (z num, 's, 'r, 'f) kinstr\n | IGt :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> (z num, 's, 'r, 'f) kinstr\n | ILe :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> (z num, 's, 'r, 'f) kinstr\n | IGe :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> (z num, 's, 'r, 'f) kinstr\n (*\n Protocol\n --------\n *)\n | IAddress :\n Script.location * (address, 's, 'r, 'f) kinstr\n -> ('a typed_contract, 's, 'r, 'f) kinstr\n | IContract :\n Script.location\n * ('a, _) ty\n * Entrypoint.t\n * ('a typed_contract option, 's, 'r, 'f) kinstr\n -> (address, 's, 'r, 'f) kinstr\n | IView :\n Script.location\n * ('a, 'b) view_signature\n * ('c, 's) stack_ty option\n * ('b option, 'c * 's, 'r, 'f) kinstr\n -> ('a, address * ('c * 's), 'r, 'f) kinstr\n | ITransfer_tokens :\n Script.location * (operation, 's, 'r, 'f) kinstr\n -> ('a, Tez.t * ('a typed_contract * 's), 'r, 'f) kinstr\n | IImplicit_account :\n Script.location * (unit typed_contract, 's, 'r, 'f) kinstr\n -> (public_key_hash, 's, 'r, 'f) kinstr\n | ICreate_contract : {\n loc : Script.location;\n storage_type : ('a, _) ty;\n code : Script.expr;\n k : (operation, address * ('c * 's), 'r, 'f) kinstr;\n }\n -> (public_key_hash option, Tez.t * ('a * ('c * 's)), 'r, 'f) kinstr\n | ISet_delegate :\n Script.location * (operation, 's, 'r, 'f) kinstr\n -> (public_key_hash option, 's, 'r, 'f) kinstr\n | INow :\n Script.location * (Script_timestamp.t, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IMin_block_time :\n Script.location * (n num, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IBalance :\n Script.location * (Tez.t, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | ILevel :\n Script.location * (n num, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | ICheck_signature :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> (public_key, signature * (bytes * 's), 'r, 'f) kinstr\n | IHash_key :\n Script.location * (public_key_hash, 's, 'r, 'f) kinstr\n -> (public_key, 's, 'r, 'f) kinstr\n | IPack :\n Script.location * ('a, _) ty * (bytes, 'b * 's, 'r, 'f) kinstr\n -> ('a, 'b * 's, 'r, 'f) kinstr\n | IUnpack :\n Script.location * ('a, _) ty * ('a option, 's, 'r, 'f) kinstr\n -> (bytes, 's, 'r, 'f) kinstr\n | IBlake2b :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, 's, 'r, 'f) kinstr\n | ISha256 :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, 's, 'r, 'f) kinstr\n | ISha512 :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, 's, 'r, 'f) kinstr\n | ISource :\n Script.location * (address, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | ISender :\n Script.location * (address, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | ISelf :\n Script.location\n * ('b, _) ty\n * Entrypoint.t\n * ('b typed_contract, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | ISelf_address :\n Script.location * (address, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IAmount :\n Script.location * (Tez.t, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | ISapling_empty_state :\n Script.location\n * Sapling.Memo_size.t\n * (Sapling.state, 'a * 's, 'b, 'f) kinstr\n -> ('a, 's, 'b, 'f) kinstr\n | ISapling_verify_update :\n Script.location\n * ((bytes, (z num, Sapling.state) pair) pair option, 's, 'r, 'f) kinstr\n -> (Sapling.transaction, Sapling.state * 's, 'r, 'f) kinstr\n | ISapling_verify_update_deprecated :\n Script.location * ((z num, Sapling.state) pair option, 's, 'r, 'f) kinstr\n -> (Sapling.Legacy.transaction, Sapling.state * 's, 'r, 'f) kinstr\n | IDig :\n Script.location\n * int\n * ('b, 'c * 't, 'c, 't, 'a, 's, 'd, 'u) stack_prefix_preservation_witness\n * ('b, 'd * 'u, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IDug :\n Script.location\n * int\n * ('c, 't, 'a, 'c * 't, 'b, 's, 'd, 'u) stack_prefix_preservation_witness\n * ('d, 'u, 'r, 'f) kinstr\n -> ('a, 'b * 's, 'r, 'f) kinstr\n | IDipn :\n Script.location\n * int\n * ('c, 't, 'd, 'v, 'a, 's, 'b, 'u) stack_prefix_preservation_witness\n * ('c, 't, 'd, 'v) kinstr\n * ('b, 'u, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IDropn :\n Script.location\n * int\n * ('b, 'u, 'b, 'u, 'a, 's, 'a, 's) stack_prefix_preservation_witness\n * ('b, 'u, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IChainId :\n Script.location * (Script_chain_id.t, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | INever : Script.location -> (never, 's, 'r, 'f) kinstr\n | IVoting_power :\n Script.location * (n num, 's, 'r, 'f) kinstr\n -> (public_key_hash, 's, 'r, 'f) kinstr\n | ITotal_voting_power :\n Script.location * (n num, 'a * 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n | IKeccak :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, 's, 'r, 'f) kinstr\n | ISha3 :\n Script.location * (bytes, 's, 'r, 'f) kinstr\n -> (bytes, 's, 'r, 'f) kinstr\n | IAdd_bls12_381_g1 :\n Script.location * (Script_bls.G1.t, 's, 'r, 'f) kinstr\n -> (Script_bls.G1.t, Script_bls.G1.t * 's, 'r, 'f) kinstr\n | IAdd_bls12_381_g2 :\n Script.location * (Script_bls.G2.t, 's, 'r, 'f) kinstr\n -> (Script_bls.G2.t, Script_bls.G2.t * 's, 'r, 'f) kinstr\n | IAdd_bls12_381_fr :\n Script.location * (Script_bls.Fr.t, 's, 'r, 'f) kinstr\n -> (Script_bls.Fr.t, Script_bls.Fr.t * 's, 'r, 'f) kinstr\n | IMul_bls12_381_g1 :\n Script.location * (Script_bls.G1.t, 's, 'r, 'f) kinstr\n -> (Script_bls.G1.t, Script_bls.Fr.t * 's, 'r, 'f) kinstr\n | IMul_bls12_381_g2 :\n Script.location * (Script_bls.G2.t, 's, 'r, 'f) kinstr\n -> (Script_bls.G2.t, Script_bls.Fr.t * 's, 'r, 'f) kinstr\n | IMul_bls12_381_fr :\n Script.location * (Script_bls.Fr.t, 's, 'r, 'f) kinstr\n -> (Script_bls.Fr.t, Script_bls.Fr.t * 's, 'r, 'f) kinstr\n | IMul_bls12_381_z_fr :\n Script.location * (Script_bls.Fr.t, 's, 'r, 'f) kinstr\n -> (Script_bls.Fr.t, 'a num * 's, 'r, 'f) kinstr\n | IMul_bls12_381_fr_z :\n Script.location * (Script_bls.Fr.t, 's, 'r, 'f) kinstr\n -> ('a num, Script_bls.Fr.t * 's, 'r, 'f) kinstr\n | IInt_bls12_381_fr :\n Script.location * (z num, 's, 'r, 'f) kinstr\n -> (Script_bls.Fr.t, 's, 'r, 'f) kinstr\n | INeg_bls12_381_g1 :\n Script.location * (Script_bls.G1.t, 's, 'r, 'f) kinstr\n -> (Script_bls.G1.t, 's, 'r, 'f) kinstr\n | INeg_bls12_381_g2 :\n Script.location * (Script_bls.G2.t, 's, 'r, 'f) kinstr\n -> (Script_bls.G2.t, 's, 'r, 'f) kinstr\n | INeg_bls12_381_fr :\n Script.location * (Script_bls.Fr.t, 's, 'r, 'f) kinstr\n -> (Script_bls.Fr.t, 's, 'r, 'f) kinstr\n | IPairing_check_bls12_381 :\n Script.location * (bool, 's, 'r, 'f) kinstr\n -> ( (Script_bls.G1.t, Script_bls.G2.t) pair Script_list.t,\n 's,\n 'r,\n 'f )\n kinstr\n | IComb :\n Script.location\n * int\n * ('a, 'b, 's, 'c, 'd, 't) comb_gadt_witness\n * ('c, 'd * 't, 'r, 'f) kinstr\n -> ('a, 'b * 's, 'r, 'f) kinstr\n | IUncomb :\n Script.location\n * int\n * ('a, 'b, 's, 'c, 'd, 't) uncomb_gadt_witness\n * ('c, 'd * 't, 'r, 'f) kinstr\n -> ('a, 'b * 's, 'r, 'f) kinstr\n | IComb_get :\n Script.location\n * int\n * ('t, 'v) comb_get_gadt_witness\n * ('v, 'a * 's, 'r, 'f) kinstr\n -> ('t, 'a * 's, 'r, 'f) kinstr\n | IComb_set :\n Script.location\n * int\n * ('a, 'b, 'c) comb_set_gadt_witness\n * ('c, 'd * 's, 'r, 'f) kinstr\n -> ('a, 'b * ('d * 's), 'r, 'f) kinstr\n | IDup_n :\n Script.location\n * int\n * ('a, 'b, 's, 't) dup_n_gadt_witness\n * ('t, 'a * ('b * 's), 'r, 'f) kinstr\n -> ('a, 'b * 's, 'r, 'f) kinstr\n | ITicket :\n Script.location\n * 'a comparable_ty option\n * ('a ticket option, 's, 'r, 'f) kinstr\n -> ('a, n num * 's, 'r, 'f) kinstr\n | ITicket_deprecated :\n Script.location * 'a comparable_ty option * ('a ticket, 's, 'r, 'f) kinstr\n -> ('a, n num * 's, 'r, 'f) kinstr\n | IRead_ticket :\n Script.location\n * 'a comparable_ty option\n * (address * ('a * n num), 'a ticket * 's, 'r, 'f) kinstr\n -> ('a ticket, 's, 'r, 'f) kinstr\n | ISplit_ticket :\n Script.location * (('a ticket * 'a ticket) option, 's, 'r, 'f) kinstr\n -> ('a ticket, (n num * n num) * 's, 'r, 'f) kinstr\n | IJoin_tickets :\n Script.location * 'a comparable_ty * ('a ticket option, 's, 'r, 'f) kinstr\n -> ('a ticket * 'a ticket, 's, 'r, 'f) kinstr\n | IOpen_chest :\n Script.location * ((bytes, bool) union, 's, 'r, 'f) kinstr\n -> ( Script_timelock.chest_key,\n Script_timelock.chest * (n num * 's),\n 'r,\n 'f )\n kinstr\n | IEmit : {\n loc : Script.location;\n tag : Entrypoint.t;\n ty : ('a, _) ty;\n unparsed_ty : Script.expr;\n k : (operation, 's, 'r, 'f) kinstr;\n }\n -> ('a, 's, 'r, 'f) kinstr\n (*\n Internal control instructions\n -----------------------------\n *)\n | IHalt : Script.location -> ('a, 's, 'a, 's) kinstr\n | ILog :\n Script.location\n * ('a, 's) stack_ty\n * logging_event\n * logger\n * ('a, 's, 'r, 'f) kinstr\n -> ('a, 's, 'r, 'f) kinstr\n\nand ('arg, 'ret) lambda =\n | Lam :\n ('arg, end_of_stack, 'ret, end_of_stack) kdescr * Script.node\n -> ('arg, 'ret) lambda\n | LamRec :\n ('arg, ('arg, 'ret) lambda * end_of_stack, 'ret, end_of_stack) kdescr\n * Script.node\n -> ('arg, 'ret) lambda\n\nand 'arg typed_contract =\n | Typed_implicit : public_key_hash -> unit typed_contract\n | Typed_implicit_with_ticket : {\n ticket_ty : ('arg ticket, _) ty;\n destination : public_key_hash;\n }\n -> 'arg ticket typed_contract\n | Typed_originated : {\n arg_ty : ('arg, _) ty;\n contract_hash : Contract_hash.t;\n entrypoint : Entrypoint.t;\n }\n -> 'arg typed_contract\n | Typed_tx_rollup : {\n arg_ty : (('a ticket, tx_rollup_l2_address) pair, _) ty;\n tx_rollup : Tx_rollup.t;\n }\n -> ('a ticket, tx_rollup_l2_address) pair typed_contract\n | Typed_sc_rollup : {\n arg_ty : ('arg, _) ty;\n sc_rollup : Sc_rollup.t;\n entrypoint : Entrypoint.t;\n }\n -> 'arg typed_contract\n | Typed_zk_rollup : {\n arg_ty : (('a ticket, bytes) pair, _) ty;\n zk_rollup : Zk_rollup.t;\n }\n -> ('a ticket, bytes) pair typed_contract\n\nand (_, _, _, _) continuation =\n | KNil : ('r, 'f, 'r, 'f) continuation\n | KCons :\n ('a, 's, 'b, 't) kinstr * ('b, 't, 'r, 'f) continuation\n -> ('a, 's, 'r, 'f) continuation\n | KReturn :\n 's * ('a, 's) stack_ty option * ('a, 's, 'r, 'f) continuation\n -> ('a, end_of_stack, 'r, 'f) continuation\n | KMap_head :\n ('a -> 'b) * ('b, 's, 'r, 'f) continuation\n -> ('a, 's, 'r, 'f) continuation\n | KUndip :\n 'b * ('b, _) ty option * ('b, 'a * 's, 'r, 'f) continuation\n -> ('a, 's, 'r, 'f) continuation\n | KLoop_in :\n ('a, 's, bool, 'a * 's) kinstr * ('a, 's, 'r, 'f) continuation\n -> (bool, 'a * 's, 'r, 'f) continuation\n | KLoop_in_left :\n ('a, 's, ('a, 'b) union, 's) kinstr * ('b, 's, 'r, 'f) continuation\n -> (('a, 'b) union, 's, 'r, 'f) continuation\n | KIter :\n ('a, 'b * 's, 'b, 's) kinstr\n * ('a, _) ty option\n * 'a list\n * ('b, 's, 'r, 'f) continuation\n -> ('b, 's, 'r, 'f) continuation\n | KList_enter_body :\n ('a, 'c * 's, 'b, 'c * 's) kinstr\n * 'a list\n * 'b Script_list.t\n * ('b Script_list.t, _) ty option\n * int\n * ('b Script_list.t, 'c * 's, 'r, 'f) continuation\n -> ('c, 's, 'r, 'f) continuation\n | KList_exit_body :\n ('a, 'c * 's, 'b, 'c * 's) kinstr\n * 'a list\n * 'b Script_list.t\n * ('b Script_list.t, _) ty option\n * int\n * ('b Script_list.t, 'c * 's, 'r, 'f) continuation\n -> ('b, 'c * 's, 'r, 'f) continuation\n | KMap_enter_body :\n ('a * 'b, 'd * 's, 'c, 'd * 's) kinstr\n * ('a * 'b) list\n * ('a, 'c) map\n * (('a, 'c) map, _) ty option\n * (('a, 'c) map, 'd * 's, 'r, 'f) continuation\n -> ('d, 's, 'r, 'f) continuation\n | KMap_exit_body :\n ('a * 'b, 'd * 's, 'c, 'd * 's) kinstr\n * ('a * 'b) list\n * ('a, 'c) map\n * 'a\n * (('a, 'c) map, _) ty option\n * (('a, 'c) map, 'd * 's, 'r, 'f) continuation\n -> ('c, 'd * 's, 'r, 'f) continuation\n | KView_exit :\n step_constants * ('a, 's, 'r, 'f) continuation\n -> ('a, 's, 'r, 'f) continuation\n | KLog :\n ('a, 's, 'r, 'f) continuation * ('a, 's) stack_ty * logger\n -> ('a, 's, 'r, 'f) continuation\n\nand ('a, 's, 'b, 'f, 'c, 'u) logging_function =\n ('a, 's, 'b, 'f) kinstr ->\n context ->\n Script.location ->\n ('c, 'u) stack_ty ->\n 'c * 'u ->\n unit\n\nand execution_trace = (Script.location * Gas.Arith.fp * Script.expr list) list\n\nand logger = {\n log_interp : 'a 's 'b 'f 'c 'u. ('a, 's, 'b, 'f, 'c, 'u) logging_function;\n get_log : unit -> execution_trace option tzresult Lwt.t;\n klog : 'a 's 'r 'f. ('a, 's, 'r, 'f) klog;\n ilog : 'a 's 'b 't 'r 'f. ('a, 's, 'b, 't, 'r, 'f) ilog;\n log_kinstr : 'a 'b 'c 'd. ('a, 'b, 'c, 'd) log_kinstr;\n}\n\nand ('a, 's, 'r, 'f) klog =\n logger ->\n Local_gas_counter.outdated_context * step_constants ->\n Local_gas_counter.local_gas_counter ->\n ('a, 's) stack_ty ->\n ('a, 's, 'r, 'f) continuation ->\n ('a, 's, 'r, 'f) continuation ->\n 'a ->\n 's ->\n ('r\n * 'f\n * Local_gas_counter.outdated_context\n * Local_gas_counter.local_gas_counter)\n tzresult\n Lwt.t\n\nand ('a, 's, 'b, 't, 'r, 'f) ilog =\n logger ->\n logging_event ->\n ('a, 's) stack_ty ->\n ('a, 's, 'b, 't, 'r, 'f) step_type\n\nand ('a, 's, 'b, 't, 'r, 'f) step_type =\n Local_gas_counter.outdated_context * step_constants ->\n Local_gas_counter.local_gas_counter ->\n ('a, 's, 'b, 't) kinstr ->\n ('b, 't, 'r, 'f) continuation ->\n 'a ->\n 's ->\n ('r\n * 'f\n * Local_gas_counter.outdated_context\n * Local_gas_counter.local_gas_counter)\n tzresult\n Lwt.t\n\nand ('a, 'b, 'c, 'd) log_kinstr =\n logger ->\n ('a, 'b) stack_ty ->\n ('a, 'b, 'c, 'd) kinstr ->\n ('a, 'b, 'c, 'd) kinstr\n\n(* ---- Auxiliary types -----------------------------------------------------*)\nand ('ty, 'comparable) ty =\n | Unit_t : (unit, yes) ty\n | Int_t : (z num, yes) ty\n | Nat_t : (n num, yes) ty\n | Signature_t : (signature, yes) ty\n | String_t : (Script_string.t, yes) ty\n | Bytes_t : (bytes, yes) ty\n | Mutez_t : (Tez.t, yes) ty\n | Key_hash_t : (public_key_hash, yes) ty\n | Key_t : (public_key, yes) ty\n | Timestamp_t : (Script_timestamp.t, yes) ty\n | Address_t : (address, yes) ty\n | Tx_rollup_l2_address_t : (tx_rollup_l2_address, yes) ty\n | Bool_t : (bool, yes) ty\n | Pair_t :\n ('a, 'ac) ty\n * ('b, 'bc) ty\n * ('a, 'b) pair ty_metadata\n * ('ac, 'bc, 'rc) dand\n -> (('a, 'b) pair, 'rc) ty\n | Union_t :\n ('a, 'ac) ty\n * ('b, 'bc) ty\n * ('a, 'b) union ty_metadata\n * ('ac, 'bc, 'rc) dand\n -> (('a, 'b) union, 'rc) ty\n | Lambda_t :\n ('arg, _) ty * ('ret, _) ty * ('arg, 'ret) lambda ty_metadata\n -> (('arg, 'ret) lambda, no) ty\n | Option_t :\n ('v, 'c) ty * 'v option ty_metadata * 'c dbool\n -> ('v option, 'c) ty\n | List_t :\n ('v, _) ty * 'v Script_list.t ty_metadata\n -> ('v Script_list.t, no) ty\n | Set_t : 'v comparable_ty * 'v set ty_metadata -> ('v set, no) ty\n | Map_t :\n 'k comparable_ty * ('v, _) ty * ('k, 'v) map ty_metadata\n -> (('k, 'v) map, no) ty\n | Big_map_t :\n 'k comparable_ty * ('v, _) ty * ('k, 'v) big_map ty_metadata\n -> (('k, 'v) big_map, no) ty\n | Contract_t :\n ('arg, _) ty * 'arg typed_contract ty_metadata\n -> ('arg typed_contract, no) ty\n | Sapling_transaction_t : Sapling.Memo_size.t -> (Sapling.transaction, no) ty\n | Sapling_transaction_deprecated_t :\n Sapling.Memo_size.t\n -> (Sapling.Legacy.transaction, no) ty\n | Sapling_state_t : Sapling.Memo_size.t -> (Sapling.state, no) ty\n | Operation_t : (operation, no) ty\n | Chain_id_t : (Script_chain_id.t, yes) ty\n | Never_t : (never, yes) ty\n | Bls12_381_g1_t : (Script_bls.G1.t, no) ty\n | Bls12_381_g2_t : (Script_bls.G2.t, no) ty\n | Bls12_381_fr_t : (Script_bls.Fr.t, no) ty\n | Ticket_t : 'a comparable_ty * 'a ticket ty_metadata -> ('a ticket, no) ty\n | Chest_key_t : (Script_timelock.chest_key, no) ty\n | Chest_t : (Script_timelock.chest, no) ty\n\nand 'ty comparable_ty = ('ty, yes) ty\n\nand ('top_ty, 'resty) stack_ty =\n | Item_t :\n ('ty, _) ty * ('ty2, 'rest) stack_ty\n -> ('ty, 'ty2 * 'rest) stack_ty\n | Bot_t : (empty_cell, empty_cell) stack_ty\n\nand ('key, 'value) big_map =\n | Big_map : {\n id : Big_map.Id.t option;\n diff : ('key, 'value) big_map_overlay;\n key_type : 'key comparable_ty;\n value_type : ('value, _) ty;\n }\n -> ('key, 'value) big_map\n\nand ('a, 's, 'r, 'f) kdescr = {\n kloc : Script.location;\n kbef : ('a, 's) stack_ty;\n kaft : ('r, 'f) stack_ty;\n kinstr : ('a, 's, 'r, 'f) kinstr;\n}\n\nand (_, _, _, _, _, _, _, _) stack_prefix_preservation_witness =\n | KPrefix :\n Script.location\n * ('a, _) ty\n * ('c, 'v, 'd, 'w, 'x, 's, 'y, 'u) stack_prefix_preservation_witness\n -> ( 'c,\n 'v,\n 'd,\n 'w,\n 'a,\n 'x * 's,\n 'a,\n 'y * 'u )\n stack_prefix_preservation_witness\n | KRest : ('a, 's, 'b, 'u, 'a, 's, 'b, 'u) stack_prefix_preservation_witness\n\nand (_, _, _, _, _, _) comb_gadt_witness =\n | Comb_one : ('a, 'x, 'before, 'a, 'x, 'before) comb_gadt_witness\n | Comb_succ :\n ('b, 'c, 's, 'd, 'e, 't) comb_gadt_witness\n -> ('a, 'b, 'c * 's, 'a * 'd, 'e, 't) comb_gadt_witness\n\nand (_, _, _, _, _, _) uncomb_gadt_witness =\n | Uncomb_one : ('a, 'x, 'before, 'a, 'x, 'before) uncomb_gadt_witness\n | Uncomb_succ :\n ('b, 'c, 's, 'd, 'e, 't) uncomb_gadt_witness\n -> ('a * 'b, 'c, 's, 'a, 'd, 'e * 't) uncomb_gadt_witness\n\nand ('before, 'after) comb_get_gadt_witness =\n | Comb_get_zero : ('b, 'b) comb_get_gadt_witness\n | Comb_get_one : ('a * 'b, 'a) comb_get_gadt_witness\n | Comb_get_plus_two :\n ('before, 'after) comb_get_gadt_witness\n -> ('a * 'before, 'after) comb_get_gadt_witness\n\nand ('value, 'before, 'after) comb_set_gadt_witness =\n | Comb_set_zero : ('value, _, 'value) comb_set_gadt_witness\n | Comb_set_one : ('value, 'hd * 'tl, 'value * 'tl) comb_set_gadt_witness\n | Comb_set_plus_two :\n ('value, 'before, 'after) comb_set_gadt_witness\n -> ('value, 'a * 'before, 'a * 'after) comb_set_gadt_witness\n\nand (_, _, _, _) dup_n_gadt_witness =\n | Dup_n_zero : ('a, _, _, 'a) dup_n_gadt_witness\n | Dup_n_succ :\n ('b, 'c, 'stack, 'd) dup_n_gadt_witness\n -> ('a, 'b, 'c * 'stack, 'd) dup_n_gadt_witness\n\nand ('input, 'output) view_signature =\n | View_signature : {\n name : Script_string.t;\n input_ty : ('input, _) ty;\n output_ty : ('output, _) ty;\n }\n -> ('input, 'output) view_signature\n\nand 'kind internal_operation_contents =\n | Transaction_to_implicit : {\n destination : Signature.Public_key_hash.t;\n amount : Tez.tez;\n }\n -> Kind.transaction internal_operation_contents\n | Transaction_to_implicit_with_ticket : {\n destination : Signature.Public_key_hash.t;\n ticket_ty : ('content ticket, _) ty;\n ticket : 'content ticket;\n unparsed_ticket : Script.lazy_expr;\n amount : Tez.tez;\n }\n -> Kind.transaction internal_operation_contents\n | Transaction_to_smart_contract : {\n destination : Contract_hash.t;\n amount : Tez.tez;\n entrypoint : Entrypoint.t;\n location : Script.location;\n parameters_ty : ('a, _) ty;\n parameters : 'a;\n unparsed_parameters : Script.expr;\n }\n -> Kind.transaction internal_operation_contents\n | Transaction_to_tx_rollup : {\n destination : Tx_rollup.t;\n parameters_ty : (('a ticket, tx_rollup_l2_address) pair, _) ty;\n parameters : ('a ticket, tx_rollup_l2_address) pair;\n unparsed_parameters : Script.expr;\n }\n -> Kind.transaction internal_operation_contents\n | Transaction_to_sc_rollup : {\n destination : Sc_rollup.t;\n entrypoint : Entrypoint.t;\n parameters_ty : ('a, _) ty;\n parameters : 'a;\n unparsed_parameters : Script.expr;\n }\n -> Kind.transaction internal_operation_contents\n | Event : {\n ty : Script.expr;\n tag : Entrypoint.t;\n unparsed_data : Script.expr;\n }\n -> Kind.event internal_operation_contents\n | Transaction_to_zk_rollup : {\n destination : Zk_rollup.t;\n parameters_ty : (('a ticket, bytes) pair, _) ty;\n parameters : ('a ticket, bytes) pair;\n unparsed_parameters : Script.expr;\n }\n -> Kind.transaction internal_operation_contents\n | Origination : {\n delegate : Signature.Public_key_hash.t option;\n code : Script.expr;\n unparsed_storage : Script.expr;\n credit : Tez.tez;\n preorigination : Contract_hash.t;\n storage_type : ('storage, _) ty;\n storage : 'storage;\n }\n -> Kind.origination internal_operation_contents\n | Delegation :\n Signature.Public_key_hash.t option\n -> Kind.delegation internal_operation_contents\n\nand 'kind internal_operation = {\n source : Destination.t;\n operation : 'kind internal_operation_contents;\n nonce : int;\n}\n\nand packed_internal_operation =\n | Internal_operation : 'kind internal_operation -> packed_internal_operation\n[@@ocaml.unboxed]\n\nand operation = {\n piop : packed_internal_operation;\n lazy_storage_diff : Lazy_storage.diffs option;\n}\n\ntype ex_ty = Ex_ty : ('a, _) ty -> ex_ty\n\ntype ('arg, 'storage) script =\n | Script : {\n code :\n (('arg, 'storage) pair, (operation Script_list.t, 'storage) pair) lambda;\n arg_type : ('arg, _) ty;\n storage : 'storage;\n storage_type : ('storage, _) ty;\n views : view_map;\n entrypoints : 'arg entrypoints;\n code_size : Cache_memory_helpers.sint;\n (* This is an over-approximation of the value size in memory, in\n bytes, of the contract's static part, that is its source\n code. This includes the code of the contract as well as the code\n of the views. The storage size is not taken into account by this\n field as it has a dynamic size. *)\n }\n -> ('arg, 'storage) script\n\nlet manager_kind :\n type kind. kind internal_operation_contents -> kind Kind.manager = function\n | Transaction_to_implicit _ -> Kind.Transaction_manager_kind\n | Transaction_to_implicit_with_ticket _ -> Kind.Transaction_manager_kind\n | Transaction_to_smart_contract _ -> Kind.Transaction_manager_kind\n | Transaction_to_tx_rollup _ -> Kind.Transaction_manager_kind\n | Transaction_to_sc_rollup _ -> Kind.Transaction_manager_kind\n | Transaction_to_zk_rollup _ -> Kind.Transaction_manager_kind\n | Event _ -> Kind.Event_manager_kind\n | Origination _ -> Kind.Origination_manager_kind\n | Delegation _ -> Kind.Delegation_manager_kind\n\nlet kinstr_location : type a s b f. (a, s, b, f) kinstr -> Script.location =\n fun i ->\n match i with\n | IDrop (loc, _) -> loc\n | IDup (loc, _) -> loc\n | ISwap (loc, _) -> loc\n | IConst (loc, _, _, _) -> loc\n | ICons_pair (loc, _) -> loc\n | ICar (loc, _) -> loc\n | ICdr (loc, _) -> loc\n | IUnpair (loc, _) -> loc\n | ICons_some (loc, _) -> loc\n | ICons_none (loc, _, _) -> loc\n | IIf_none {loc; _} -> loc\n | IOpt_map {loc; _} -> loc\n | ICons_left (loc, _, _) -> loc\n | ICons_right (loc, _, _) -> loc\n | IIf_left {loc; _} -> loc\n | ICons_list (loc, _) -> loc\n | INil (loc, _, _) -> loc\n | IIf_cons {loc; _} -> loc\n | IList_map (loc, _, _, _) -> loc\n | IList_iter (loc, _, _, _) -> loc\n | IList_size (loc, _) -> loc\n | IEmpty_set (loc, _, _) -> loc\n | ISet_iter (loc, _, _, _) -> loc\n | ISet_mem (loc, _) -> loc\n | ISet_update (loc, _) -> loc\n | ISet_size (loc, _) -> loc\n | IEmpty_map (loc, _, _, _) -> loc\n | IMap_map (loc, _, _, _) -> loc\n | IMap_iter (loc, _, _, _) -> loc\n | IMap_mem (loc, _) -> loc\n | IMap_get (loc, _) -> loc\n | IMap_update (loc, _) -> loc\n | IMap_get_and_update (loc, _) -> loc\n | IMap_size (loc, _) -> loc\n | IEmpty_big_map (loc, _, _, _) -> loc\n | IBig_map_mem (loc, _) -> loc\n | IBig_map_get (loc, _) -> loc\n | IBig_map_update (loc, _) -> loc\n | IBig_map_get_and_update (loc, _) -> loc\n | IConcat_string (loc, _) -> loc\n | IConcat_string_pair (loc, _) -> loc\n | ISlice_string (loc, _) -> loc\n | IString_size (loc, _) -> loc\n | IConcat_bytes (loc, _) -> loc\n | IConcat_bytes_pair (loc, _) -> loc\n | ISlice_bytes (loc, _) -> loc\n | IBytes_size (loc, _) -> loc\n | ILsl_bytes (loc, _) -> loc\n | ILsr_bytes (loc, _) -> loc\n | IOr_bytes (loc, _) -> loc\n | IAnd_bytes (loc, _) -> loc\n | IXor_bytes (loc, _) -> loc\n | INot_bytes (loc, _) -> loc\n | INat_bytes (loc, _) -> loc\n | IBytes_nat (loc, _) -> loc\n | IInt_bytes (loc, _) -> loc\n | IBytes_int (loc, _) -> loc\n | IAdd_seconds_to_timestamp (loc, _) -> loc\n | IAdd_timestamp_to_seconds (loc, _) -> loc\n | ISub_timestamp_seconds (loc, _) -> loc\n | IDiff_timestamps (loc, _) -> loc\n | IAdd_tez (loc, _) -> loc\n | ISub_tez (loc, _) -> loc\n | ISub_tez_legacy (loc, _) -> loc\n | IMul_teznat (loc, _) -> loc\n | IMul_nattez (loc, _) -> loc\n | IEdiv_teznat (loc, _) -> loc\n | IEdiv_tez (loc, _) -> loc\n | IOr (loc, _) -> loc\n | IAnd (loc, _) -> loc\n | IXor (loc, _) -> loc\n | INot (loc, _) -> loc\n | IIs_nat (loc, _) -> loc\n | INeg (loc, _) -> loc\n | IAbs_int (loc, _) -> loc\n | IInt_nat (loc, _) -> loc\n | IAdd_int (loc, _) -> loc\n | IAdd_nat (loc, _) -> loc\n | ISub_int (loc, _) -> loc\n | IMul_int (loc, _) -> loc\n | IMul_nat (loc, _) -> loc\n | IEdiv_int (loc, _) -> loc\n | IEdiv_nat (loc, _) -> loc\n | ILsl_nat (loc, _) -> loc\n | ILsr_nat (loc, _) -> loc\n | IOr_nat (loc, _) -> loc\n | IAnd_nat (loc, _) -> loc\n | IAnd_int_nat (loc, _) -> loc\n | IXor_nat (loc, _) -> loc\n | INot_int (loc, _) -> loc\n | IIf {loc; _} -> loc\n | ILoop (loc, _, _) -> loc\n | ILoop_left (loc, _, _) -> loc\n | IDip (loc, _, _, _) -> loc\n | IExec (loc, _, _) -> loc\n | IApply (loc, _, _) -> loc\n | ILambda (loc, _, _) -> loc\n | IFailwith (loc, _) -> loc\n | ICompare (loc, _, _) -> loc\n | IEq (loc, _) -> loc\n | INeq (loc, _) -> loc\n | ILt (loc, _) -> loc\n | IGt (loc, _) -> loc\n | ILe (loc, _) -> loc\n | IGe (loc, _) -> loc\n | IAddress (loc, _) -> loc\n | IContract (loc, _, _, _) -> loc\n | ITransfer_tokens (loc, _) -> loc\n | IView (loc, _, _, _) -> loc\n | IImplicit_account (loc, _) -> loc\n | ICreate_contract {loc; _} -> loc\n | ISet_delegate (loc, _) -> loc\n | INow (loc, _) -> loc\n | IMin_block_time (loc, _) -> loc\n | IBalance (loc, _) -> loc\n | ILevel (loc, _) -> loc\n | ICheck_signature (loc, _) -> loc\n | IHash_key (loc, _) -> loc\n | IPack (loc, _, _) -> loc\n | IUnpack (loc, _, _) -> loc\n | IBlake2b (loc, _) -> loc\n | ISha256 (loc, _) -> loc\n | ISha512 (loc, _) -> loc\n | ISource (loc, _) -> loc\n | ISender (loc, _) -> loc\n | ISelf (loc, _, _, _) -> loc\n | ISelf_address (loc, _) -> loc\n | IAmount (loc, _) -> loc\n | ISapling_empty_state (loc, _, _) -> loc\n | ISapling_verify_update (loc, _) -> loc\n | ISapling_verify_update_deprecated (loc, _) -> loc\n | IDig (loc, _, _, _) -> loc\n | IDug (loc, _, _, _) -> loc\n | IDipn (loc, _, _, _, _) -> loc\n | IDropn (loc, _, _, _) -> loc\n | IChainId (loc, _) -> loc\n | INever loc -> loc\n | IVoting_power (loc, _) -> loc\n | ITotal_voting_power (loc, _) -> loc\n | IKeccak (loc, _) -> loc\n | ISha3 (loc, _) -> loc\n | IAdd_bls12_381_g1 (loc, _) -> loc\n | IAdd_bls12_381_g2 (loc, _) -> loc\n | IAdd_bls12_381_fr (loc, _) -> loc\n | IMul_bls12_381_g1 (loc, _) -> loc\n | IMul_bls12_381_g2 (loc, _) -> loc\n | IMul_bls12_381_fr (loc, _) -> loc\n | IMul_bls12_381_z_fr (loc, _) -> loc\n | IMul_bls12_381_fr_z (loc, _) -> loc\n | IInt_bls12_381_fr (loc, _) -> loc\n | INeg_bls12_381_g1 (loc, _) -> loc\n | INeg_bls12_381_g2 (loc, _) -> loc\n | INeg_bls12_381_fr (loc, _) -> loc\n | IPairing_check_bls12_381 (loc, _) -> loc\n | IComb (loc, _, _, _) -> loc\n | IUncomb (loc, _, _, _) -> loc\n | IComb_get (loc, _, _, _) -> loc\n | IComb_set (loc, _, _, _) -> loc\n | IDup_n (loc, _, _, _) -> loc\n | ITicket (loc, _, _) -> loc\n | ITicket_deprecated (loc, _, _) -> loc\n | IRead_ticket (loc, _, _) -> loc\n | ISplit_ticket (loc, _) -> loc\n | IJoin_tickets (loc, _, _) -> loc\n | IOpen_chest (loc, _) -> loc\n | IEmit {loc; _} -> loc\n | IHalt loc -> loc\n | ILog (loc, _, _, _, _) -> loc\n\nlet meta_basic = {size = Type_size.one}\n\nlet ty_metadata : type a ac. (a, ac) ty -> a ty_metadata = function\n | Unit_t | Never_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t\n | Mutez_t | Bool_t | Key_hash_t | Key_t | Timestamp_t | Chain_id_t | Address_t\n | Tx_rollup_l2_address_t ->\n meta_basic\n | Pair_t (_, _, meta, _) -> meta\n | Union_t (_, _, meta, _) -> meta\n | Option_t (_, meta, _) -> meta\n | Lambda_t (_, _, meta) -> meta\n | List_t (_, meta) -> meta\n | Set_t (_, meta) -> meta\n | Map_t (_, _, meta) -> meta\n | Big_map_t (_, _, meta) -> meta\n | Ticket_t (_, meta) -> meta\n | Contract_t (_, meta) -> meta\n | Sapling_transaction_t _ | Sapling_transaction_deprecated_t _\n | Sapling_state_t _ | Operation_t | Bls12_381_g1_t | Bls12_381_g2_t\n | Bls12_381_fr_t | Chest_t | Chest_key_t ->\n meta_basic\n\nlet ty_size t = (ty_metadata t).size\n\nlet is_comparable : type v c. (v, c) ty -> c dbool = function\n | Never_t -> Yes\n | Unit_t -> Yes\n | Int_t -> Yes\n | Nat_t -> Yes\n | Signature_t -> Yes\n | String_t -> Yes\n | Bytes_t -> Yes\n | Mutez_t -> Yes\n | Bool_t -> Yes\n | Key_hash_t -> Yes\n | Key_t -> Yes\n | Timestamp_t -> Yes\n | Chain_id_t -> Yes\n | Address_t -> Yes\n | Tx_rollup_l2_address_t -> Yes\n | Pair_t (_, _, _, dand) -> dbool_of_dand dand\n | Union_t (_, _, _, dand) -> dbool_of_dand dand\n | Option_t (_, _, cmp) -> cmp\n | Lambda_t _ -> No\n | List_t _ -> No\n | Set_t _ -> No\n | Map_t _ -> No\n | Big_map_t _ -> No\n | Ticket_t _ -> No\n | Contract_t _ -> No\n | Sapling_transaction_t _ -> No\n | Sapling_transaction_deprecated_t _ -> No\n | Sapling_state_t _ -> No\n | Operation_t -> No\n | Bls12_381_g1_t -> No\n | Bls12_381_g2_t -> No\n | Bls12_381_fr_t -> No\n | Chest_t -> No\n | Chest_key_t -> No\n\ntype 'v ty_ex_c = Ty_ex_c : ('v, _) ty -> 'v ty_ex_c [@@ocaml.unboxed]\n\nlet unit_t = Unit_t\n\nlet int_t = Int_t\n\nlet nat_t = Nat_t\n\nlet signature_t = Signature_t\n\nlet string_t = String_t\n\nlet bytes_t = Bytes_t\n\nlet mutez_t = Mutez_t\n\nlet key_hash_t = Key_hash_t\n\nlet key_t = Key_t\n\nlet timestamp_t = Timestamp_t\n\nlet address_t = Address_t\n\nlet bool_t = Bool_t\n\nlet tx_rollup_l2_address_t = Tx_rollup_l2_address_t\n\nlet pair_t :\n type a ac b bc.\n Script.location -> (a, ac) ty -> (b, bc) ty -> (a, b) pair ty_ex_c tzresult\n =\n fun loc l r ->\n Type_size.compound2 loc (ty_size l) (ty_size r) >|? fun size ->\n let (Ex_dand cmp) = dand (is_comparable l) (is_comparable r) in\n Ty_ex_c (Pair_t (l, r, {size}, cmp))\n\nlet pair_3_t loc l m r = pair_t loc m r >>? fun (Ty_ex_c r) -> pair_t loc l r\n\nlet comparable_pair_t loc l r =\n Type_size.compound2 loc (ty_size l) (ty_size r) >|? fun size ->\n Pair_t (l, r, {size}, YesYes)\n\nlet comparable_pair_3_t loc l m r =\n comparable_pair_t loc m r >>? fun r -> comparable_pair_t loc l r\n\nlet union_t :\n type a ac b bc.\n Script.location -> (a, ac) ty -> (b, bc) ty -> (a, b) union ty_ex_c tzresult\n =\n fun loc l r ->\n Type_size.compound2 loc (ty_size l) (ty_size r) >|? fun size ->\n let (Ex_dand cmp) = dand (is_comparable l) (is_comparable r) in\n Ty_ex_c (Union_t (l, r, {size}, cmp))\n\nlet union_bytes_bool_t =\n Union_t (bytes_t, bool_t, {size = Type_size.three}, YesYes)\n\nlet comparable_union_t loc l r =\n Type_size.compound2 loc (ty_size l) (ty_size r) >|? fun size ->\n Union_t (l, r, {size}, YesYes)\n\nlet lambda_t loc l r =\n Type_size.compound2 loc (ty_size l) (ty_size r) >|? fun size ->\n Lambda_t (l, r, {size})\n\nlet option_t loc t =\n Type_size.compound1 loc (ty_size t) >|? fun size ->\n let cmp = is_comparable t in\n Option_t (t, {size}, cmp)\n\nlet option_mutez_t = Option_t (mutez_t, {size = Type_size.two}, Yes)\n\nlet option_string_t = Option_t (string_t, {size = Type_size.two}, Yes)\n\nlet option_bytes_t = Option_t (bytes_t, {size = Type_size.two}, Yes)\n\nlet option_nat_t = Option_t (nat_t, {size = Type_size.two}, Yes)\n\nlet option_pair_nat_nat_t =\n Option_t\n ( Pair_t (nat_t, nat_t, {size = Type_size.three}, YesYes),\n {size = Type_size.four},\n Yes )\n\nlet option_pair_nat_mutez_t =\n Option_t\n ( Pair_t (nat_t, mutez_t, {size = Type_size.three}, YesYes),\n {size = Type_size.four},\n Yes )\n\nlet option_pair_mutez_mutez_t =\n Option_t\n ( Pair_t (mutez_t, mutez_t, {size = Type_size.three}, YesYes),\n {size = Type_size.four},\n Yes )\n\nlet option_pair_int_nat_t =\n Option_t\n ( Pair_t (int_t, nat_t, {size = Type_size.three}, YesYes),\n {size = Type_size.four},\n Yes )\n\nlet list_t loc t =\n Type_size.compound1 loc (ty_size t) >|? fun size -> List_t (t, {size})\n\nlet operation_t = Operation_t\n\nlet list_operation_t = List_t (operation_t, {size = Type_size.two})\n\nlet set_t loc t =\n Type_size.compound1 loc (ty_size t) >|? fun size -> Set_t (t, {size})\n\nlet map_t loc l r =\n Type_size.compound2 loc (ty_size l) (ty_size r) >|? fun size ->\n Map_t (l, r, {size})\n\nlet big_map_t loc l r =\n Type_size.compound2 loc (ty_size l) (ty_size r) >|? fun size ->\n Big_map_t (l, r, {size})\n\nlet contract_t loc t =\n Type_size.compound1 loc (ty_size t) >|? fun size -> Contract_t (t, {size})\n\nlet contract_unit_t = Contract_t (unit_t, {size = Type_size.two})\n\nlet sapling_transaction_t ~memo_size = Sapling_transaction_t memo_size\n\nlet sapling_transaction_deprecated_t ~memo_size =\n Sapling_transaction_deprecated_t memo_size\n\nlet sapling_state_t ~memo_size = Sapling_state_t memo_size\n\nlet chain_id_t = Chain_id_t\n\nlet never_t = Never_t\n\nlet bls12_381_g1_t = Bls12_381_g1_t\n\nlet bls12_381_g2_t = Bls12_381_g2_t\n\nlet bls12_381_fr_t = Bls12_381_fr_t\n\nlet ticket_t loc t =\n Type_size.compound1 loc (ty_size t) >|? fun size -> Ticket_t (t, {size})\n\nlet chest_key_t = Chest_key_t\n\nlet chest_t = Chest_t\n\ntype 'a kinstr_traverse = {\n apply : 'b 'u 'r 'f. 'a -> ('b, 'u, 'r, 'f) kinstr -> 'a;\n}\n\nlet kinstr_traverse i init f =\n let rec aux :\n type ret a s r f. 'accu -> (a, s, r, f) kinstr -> ('accu -> ret) -> ret =\n fun accu t continue ->\n let accu = f.apply accu t in\n let next k =\n (aux [@ocaml.tailcall]) accu k (fun accu ->\n (continue [@ocaml.tailcall]) accu)\n in\n let next2 k1 k2 =\n (aux [@ocaml.tailcall]) accu k1 (fun accu ->\n (aux [@ocaml.tailcall]) accu k2 (fun accu ->\n (continue [@ocaml.tailcall]) accu))\n in\n let next3 k1 k2 k3 =\n (aux [@ocaml.tailcall]) accu k1 (fun accu ->\n (aux [@ocaml.tailcall]) accu k2 (fun accu ->\n (aux [@ocaml.tailcall]) accu k3 (fun accu ->\n (continue [@ocaml.tailcall]) accu)))\n in\n let return () = (continue [@ocaml.tailcall]) accu in\n match t with\n | IDrop (_, k) -> (next [@ocaml.tailcall]) k\n | IDup (_, k) -> (next [@ocaml.tailcall]) k\n | ISwap (_, k) -> (next [@ocaml.tailcall]) k\n | IConst (_, _, _, k) -> (next [@ocaml.tailcall]) k\n | ICons_pair (_, k) -> (next [@ocaml.tailcall]) k\n | ICar (_, k) -> (next [@ocaml.tailcall]) k\n | ICdr (_, k) -> (next [@ocaml.tailcall]) k\n | IUnpair (_, k) -> (next [@ocaml.tailcall]) k\n | ICons_some (_, k) -> (next [@ocaml.tailcall]) k\n | ICons_none (_, _, k) -> (next [@ocaml.tailcall]) k\n | IIf_none {loc = _; branch_if_none = k1; branch_if_some = k2; k} ->\n (next3 [@ocaml.tailcall]) k1 k2 k\n | IOpt_map {loc = _; body; k} -> (next2 [@ocaml.tailcall]) body k\n | ICons_left (_, _, k) -> (next [@ocaml.tailcall]) k\n | ICons_right (_, _, k) -> (next [@ocaml.tailcall]) k\n | IIf_left {loc = _; branch_if_left = k1; branch_if_right = k2; k} ->\n (next3 [@ocaml.tailcall]) k1 k2 k\n | ICons_list (_, k) -> (next [@ocaml.tailcall]) k\n | INil (_, _, k) -> (next [@ocaml.tailcall]) k\n | IIf_cons {loc = _; branch_if_nil = k1; branch_if_cons = k2; k} ->\n (next3 [@ocaml.tailcall]) k1 k2 k\n | IList_map (_, k1, _, k2) -> (next2 [@ocaml.tailcall]) k1 k2\n | IList_iter (_, _, k1, k2) -> (next2 [@ocaml.tailcall]) k1 k2\n | IList_size (_, k) -> (next [@ocaml.tailcall]) k\n | IEmpty_set (_, _, k) -> (next [@ocaml.tailcall]) k\n | ISet_iter (_, _, k1, k2) -> (next2 [@ocaml.tailcall]) k1 k2\n | ISet_mem (_, k) -> (next [@ocaml.tailcall]) k\n | ISet_update (_, k) -> (next [@ocaml.tailcall]) k\n | ISet_size (_, k) -> (next [@ocaml.tailcall]) k\n | IEmpty_map (_, _, _, k) -> (next [@ocaml.tailcall]) k\n | IMap_map (_, _, k1, k2) -> (next2 [@ocaml.tailcall]) k1 k2\n | IMap_iter (_, _, k1, k2) -> (next2 [@ocaml.tailcall]) k1 k2\n | IMap_mem (_, k) -> (next [@ocaml.tailcall]) k\n | IMap_get (_, k) -> (next [@ocaml.tailcall]) k\n | IMap_update (_, k) -> (next [@ocaml.tailcall]) k\n | IMap_get_and_update (_, k) -> (next [@ocaml.tailcall]) k\n | IMap_size (_, k) -> (next [@ocaml.tailcall]) k\n | IEmpty_big_map (_, _, _, k) -> (next [@ocaml.tailcall]) k\n | IBig_map_mem (_, k) -> (next [@ocaml.tailcall]) k\n | IBig_map_get (_, k) -> (next [@ocaml.tailcall]) k\n | IBig_map_update (_, k) -> (next [@ocaml.tailcall]) k\n | IBig_map_get_and_update (_, k) -> (next [@ocaml.tailcall]) k\n | IConcat_string (_, k) -> (next [@ocaml.tailcall]) k\n | IConcat_string_pair (_, k) -> (next [@ocaml.tailcall]) k\n | ISlice_string (_, k) -> (next [@ocaml.tailcall]) k\n | IString_size (_, k) -> (next [@ocaml.tailcall]) k\n | IConcat_bytes (_, k) -> (next [@ocaml.tailcall]) k\n | IConcat_bytes_pair (_, k) -> (next [@ocaml.tailcall]) k\n | ISlice_bytes (_, k) -> (next [@ocaml.tailcall]) k\n | IBytes_size (_, k) -> (next [@ocaml.tailcall]) k\n | ILsl_bytes (_, k) -> (next [@ocaml.tailcall]) k\n | ILsr_bytes (_, k) -> (next [@ocaml.tailcall]) k\n | IOr_bytes (_, k) -> (next [@ocaml.tailcall]) k\n | IAnd_bytes (_, k) -> (next [@ocaml.tailcall]) k\n | IXor_bytes (_, k) -> (next [@ocaml.tailcall]) k\n | INot_bytes (_, k) -> (next [@ocaml.tailcall]) k\n | INat_bytes (_, k) -> (next [@ocaml.tailcall]) k\n | IBytes_nat (_, k) -> (next [@ocaml.tailcall]) k\n | IInt_bytes (_, k) -> (next [@ocaml.tailcall]) k\n | IBytes_int (_, k) -> (next [@ocaml.tailcall]) k\n | IAdd_seconds_to_timestamp (_, k) -> (next [@ocaml.tailcall]) k\n | IAdd_timestamp_to_seconds (_, k) -> (next [@ocaml.tailcall]) k\n | ISub_timestamp_seconds (_, k) -> (next [@ocaml.tailcall]) k\n | IDiff_timestamps (_, k) -> (next [@ocaml.tailcall]) k\n | IAdd_tez (_, k) -> (next [@ocaml.tailcall]) k\n | ISub_tez (_, k) -> (next [@ocaml.tailcall]) k\n | ISub_tez_legacy (_, k) -> (next [@ocaml.tailcall]) k\n | IMul_teznat (_, k) -> (next [@ocaml.tailcall]) k\n | IMul_nattez (_, k) -> (next [@ocaml.tailcall]) k\n | IEdiv_teznat (_, k) -> (next [@ocaml.tailcall]) k\n | IEdiv_tez (_, k) -> (next [@ocaml.tailcall]) k\n | IOr (_, k) -> (next [@ocaml.tailcall]) k\n | IAnd (_, k) -> (next [@ocaml.tailcall]) k\n | IXor (_, k) -> (next [@ocaml.tailcall]) k\n | INot (_, k) -> (next [@ocaml.tailcall]) k\n | IIs_nat (_, k) -> (next [@ocaml.tailcall]) k\n | INeg (_, k) -> (next [@ocaml.tailcall]) k\n | IAbs_int (_, k) -> (next [@ocaml.tailcall]) k\n | IInt_nat (_, k) -> (next [@ocaml.tailcall]) k\n | IAdd_int (_, k) -> (next [@ocaml.tailcall]) k\n | IAdd_nat (_, k) -> (next [@ocaml.tailcall]) k\n | ISub_int (_, k) -> (next [@ocaml.tailcall]) k\n | IMul_int (_, k) -> (next [@ocaml.tailcall]) k\n | IMul_nat (_, k) -> (next [@ocaml.tailcall]) k\n | IEdiv_int (_, k) -> (next [@ocaml.tailcall]) k\n | IEdiv_nat (_, k) -> (next [@ocaml.tailcall]) k\n | ILsl_nat (_, k) -> (next [@ocaml.tailcall]) k\n | ILsr_nat (_, k) -> (next [@ocaml.tailcall]) k\n | IOr_nat (_, k) -> (next [@ocaml.tailcall]) k\n | IAnd_nat (_, k) -> (next [@ocaml.tailcall]) k\n | IAnd_int_nat (_, k) -> (next [@ocaml.tailcall]) k\n | IXor_nat (_, k) -> (next [@ocaml.tailcall]) k\n | INot_int (_, k) -> (next [@ocaml.tailcall]) k\n | IIf {loc = _; branch_if_true = k1; branch_if_false = k2; k} ->\n (next3 [@ocaml.tailcall]) k1 k2 k\n | ILoop (_, k1, k2) -> (next2 [@ocaml.tailcall]) k1 k2\n | ILoop_left (_, k1, k2) -> (next2 [@ocaml.tailcall]) k1 k2\n | IDip (_, k1, _, k2) -> (next2 [@ocaml.tailcall]) k1 k2\n | IExec (_, _, k) -> (next [@ocaml.tailcall]) k\n | IApply (_, _, k) -> (next [@ocaml.tailcall]) k\n | ILambda (_, _, k) -> (next [@ocaml.tailcall]) k\n | IFailwith (_, _) -> (return [@ocaml.tailcall]) ()\n | ICompare (_, _, k) -> (next [@ocaml.tailcall]) k\n | IEq (_, k) -> (next [@ocaml.tailcall]) k\n | INeq (_, k) -> (next [@ocaml.tailcall]) k\n | ILt (_, k) -> (next [@ocaml.tailcall]) k\n | IGt (_, k) -> (next [@ocaml.tailcall]) k\n | ILe (_, k) -> (next [@ocaml.tailcall]) k\n | IGe (_, k) -> (next [@ocaml.tailcall]) k\n | IAddress (_, k) -> (next [@ocaml.tailcall]) k\n | IContract (_, _, _, k) -> (next [@ocaml.tailcall]) k\n | IView (_, _, _, k) -> (next [@ocaml.tailcall]) k\n | ITransfer_tokens (_, k) -> (next [@ocaml.tailcall]) k\n | IImplicit_account (_, k) -> (next [@ocaml.tailcall]) k\n | ICreate_contract {k; _} -> (next [@ocaml.tailcall]) k\n | ISet_delegate (_, k) -> (next [@ocaml.tailcall]) k\n | INow (_, k) -> (next [@ocaml.tailcall]) k\n | IMin_block_time (_, k) -> (next [@ocaml.tailcall]) k\n | IBalance (_, k) -> (next [@ocaml.tailcall]) k\n | ILevel (_, k) -> (next [@ocaml.tailcall]) k\n | ICheck_signature (_, k) -> (next [@ocaml.tailcall]) k\n | IHash_key (_, k) -> (next [@ocaml.tailcall]) k\n | IPack (_, _, k) -> (next [@ocaml.tailcall]) k\n | IUnpack (_, _, k) -> (next [@ocaml.tailcall]) k\n | IBlake2b (_, k) -> (next [@ocaml.tailcall]) k\n | ISha256 (_, k) -> (next [@ocaml.tailcall]) k\n | ISha512 (_, k) -> (next [@ocaml.tailcall]) k\n | ISource (_, k) -> (next [@ocaml.tailcall]) k\n | ISender (_, k) -> (next [@ocaml.tailcall]) k\n | ISelf (_, _, _, k) -> (next [@ocaml.tailcall]) k\n | ISelf_address (_, k) -> (next [@ocaml.tailcall]) k\n | IAmount (_, k) -> (next [@ocaml.tailcall]) k\n | ISapling_empty_state (_, _, k) -> (next [@ocaml.tailcall]) k\n | ISapling_verify_update (_, k) -> (next [@ocaml.tailcall]) k\n | ISapling_verify_update_deprecated (_, k) -> (next [@ocaml.tailcall]) k\n | IDig (_, _, _, k) -> (next [@ocaml.tailcall]) k\n | IDug (_, _, _, k) -> (next [@ocaml.tailcall]) k\n | IDipn (_, _, _, k1, k2) -> (next2 [@ocaml.tailcall]) k1 k2\n | IDropn (_, _, _, k) -> (next [@ocaml.tailcall]) k\n | IChainId (_, k) -> (next [@ocaml.tailcall]) k\n | INever _ -> (return [@ocaml.tailcall]) ()\n | IVoting_power (_, k) -> (next [@ocaml.tailcall]) k\n | ITotal_voting_power (_, k) -> (next [@ocaml.tailcall]) k\n | IKeccak (_, k) -> (next [@ocaml.tailcall]) k\n | ISha3 (_, k) -> (next [@ocaml.tailcall]) k\n | IAdd_bls12_381_g1 (_, k) -> (next [@ocaml.tailcall]) k\n | IAdd_bls12_381_g2 (_, k) -> (next [@ocaml.tailcall]) k\n | IAdd_bls12_381_fr (_, k) -> (next [@ocaml.tailcall]) k\n | IMul_bls12_381_g1 (_, k) -> (next [@ocaml.tailcall]) k\n | IMul_bls12_381_g2 (_, k) -> (next [@ocaml.tailcall]) k\n | IMul_bls12_381_fr (_, k) -> (next [@ocaml.tailcall]) k\n | IMul_bls12_381_z_fr (_, k) -> (next [@ocaml.tailcall]) k\n | IMul_bls12_381_fr_z (_, k) -> (next [@ocaml.tailcall]) k\n | IInt_bls12_381_fr (_, k) -> (next [@ocaml.tailcall]) k\n | INeg_bls12_381_g1 (_, k) -> (next [@ocaml.tailcall]) k\n | INeg_bls12_381_g2 (_, k) -> (next [@ocaml.tailcall]) k\n | INeg_bls12_381_fr (_, k) -> (next [@ocaml.tailcall]) k\n | IPairing_check_bls12_381 (_, k) -> (next [@ocaml.tailcall]) k\n | IComb (_, _, _, k) -> (next [@ocaml.tailcall]) k\n | IUncomb (_, _, _, k) -> (next [@ocaml.tailcall]) k\n | IComb_get (_, _, _, k) -> (next [@ocaml.tailcall]) k\n | IComb_set (_, _, _, k) -> (next [@ocaml.tailcall]) k\n | IDup_n (_, _, _, k) -> (next [@ocaml.tailcall]) k\n | ITicket (_, _, k) -> (next [@ocaml.tailcall]) k\n | ITicket_deprecated (_, _, k) -> (next [@ocaml.tailcall]) k\n | IRead_ticket (_, _, k) -> (next [@ocaml.tailcall]) k\n | ISplit_ticket (_, k) -> (next [@ocaml.tailcall]) k\n | IJoin_tickets (_, _, k) -> (next [@ocaml.tailcall]) k\n | IOpen_chest (_, k) -> (next [@ocaml.tailcall]) k\n | IEmit {k; _} -> (next [@ocaml.tailcall]) k\n | IHalt _ -> (return [@ocaml.tailcall]) ()\n | ILog (_, _, _, _, k) -> (next [@ocaml.tailcall]) k\n in\n aux init i (fun accu -> accu)\n\ntype 'a ty_traverse = {apply : 't 'tc. 'a -> ('t, 'tc) ty -> 'a}\n\nlet ty_traverse =\n let rec aux :\n type ret t tc accu.\n accu ty_traverse -> accu -> (t, tc) ty -> (accu -> ret) -> ret =\n fun f accu ty continue ->\n let accu = f.apply accu ty in\n match ty with\n | Unit_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t | Mutez_t\n | Key_hash_t | Key_t | Timestamp_t | Address_t | Tx_rollup_l2_address_t\n | Bool_t | Sapling_transaction_t _ | Sapling_transaction_deprecated_t _\n | Sapling_state_t _ | Operation_t | Chain_id_t | Never_t | Bls12_381_g1_t\n | Bls12_381_g2_t | Bls12_381_fr_t ->\n (continue [@ocaml.tailcall]) accu\n | Ticket_t (cty, _) -> aux f accu cty continue\n | Chest_key_t | Chest_t -> (continue [@ocaml.tailcall]) accu\n | Pair_t (ty1, ty2, _, _) ->\n (next2 [@ocaml.tailcall]) f accu ty1 ty2 continue\n | Union_t (ty1, ty2, _, _) ->\n (next2 [@ocaml.tailcall]) f accu ty1 ty2 continue\n | Lambda_t (ty1, ty2, _) ->\n (next2 [@ocaml.tailcall]) f accu ty1 ty2 continue\n | Option_t (ty1, _, _) -> (next [@ocaml.tailcall]) f accu ty1 continue\n | List_t (ty1, _) -> (next [@ocaml.tailcall]) f accu ty1 continue\n | Set_t (cty, _) -> (aux [@ocaml.tailcall]) f accu cty continue\n | Map_t (cty, ty1, _) ->\n (aux [@ocaml.tailcall]) f accu cty (fun accu ->\n (next [@ocaml.tailcall]) f accu ty1 continue)\n | Big_map_t (cty, ty1, _) ->\n (aux [@ocaml.tailcall]) f accu cty (fun accu ->\n (next [@ocaml.tailcall]) f accu ty1 continue)\n | Contract_t (ty1, _) -> (next [@ocaml.tailcall]) f accu ty1 continue\n and next2 :\n type a ac b bc ret accu.\n accu ty_traverse ->\n accu ->\n (a, ac) ty ->\n (b, bc) ty ->\n (accu -> ret) ->\n ret =\n fun f accu ty1 ty2 continue ->\n (aux [@ocaml.tailcall]) f accu ty1 (fun accu ->\n (aux [@ocaml.tailcall]) f accu ty2 (fun accu ->\n (continue [@ocaml.tailcall]) accu))\n and next :\n type a ac ret accu.\n accu ty_traverse -> accu -> (a, ac) ty -> (accu -> ret) -> ret =\n fun f accu ty1 continue ->\n (aux [@ocaml.tailcall]) f accu ty1 (fun accu ->\n (continue [@ocaml.tailcall]) accu)\n in\n fun ty init f -> aux f init ty (fun accu -> accu)\n\ntype 'accu stack_ty_traverse = {\n apply : 'ty 's. 'accu -> ('ty, 's) stack_ty -> 'accu;\n}\n\nlet stack_ty_traverse (type a t) (sty : (a, t) stack_ty) init f =\n let rec aux : type b u. 'accu -> (b, u) stack_ty -> 'accu =\n fun accu sty ->\n match sty with\n | Bot_t -> f.apply accu sty\n | Item_t (_, sty') -> aux (f.apply accu sty) sty'\n in\n aux init sty\n\ntype 'a value_traverse = {apply : 't 'tc. 'a -> ('t, 'tc) ty -> 't -> 'a}\n\nlet value_traverse (type t tc) (ty : (t, tc) ty) (x : t) init f =\n let rec aux : type ret t tc. 'accu -> (t, tc) ty -> t -> ('accu -> ret) -> ret\n =\n fun accu ty x continue ->\n let accu = f.apply accu ty x in\n let next2 ty1 ty2 x1 x2 =\n (aux [@ocaml.tailcall]) accu ty1 x1 (fun accu ->\n (aux [@ocaml.tailcall]) accu ty2 x2 (fun accu ->\n (continue [@ocaml.tailcall]) accu))\n in\n let next ty1 x1 =\n (aux [@ocaml.tailcall]) accu ty1 x1 (fun accu ->\n (continue [@ocaml.tailcall]) accu)\n in\n let return () = (continue [@ocaml.tailcall]) accu in\n let rec on_list ty' accu = function\n | [] -> (continue [@ocaml.tailcall]) accu\n | x :: xs ->\n (aux [@ocaml.tailcall]) accu ty' x (fun accu ->\n (on_list [@ocaml.tailcall]) ty' accu xs)\n in\n match ty with\n | Unit_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t | Mutez_t\n | Key_hash_t | Key_t | Timestamp_t | Address_t | Tx_rollup_l2_address_t\n | Bool_t | Sapling_transaction_t _ | Sapling_transaction_deprecated_t _\n | Sapling_state_t _ | Operation_t | Chain_id_t | Never_t | Bls12_381_g1_t\n | Bls12_381_g2_t | Bls12_381_fr_t | Chest_key_t | Chest_t\n | Lambda_t (_, _, _) ->\n (return [@ocaml.tailcall]) ()\n | Pair_t (ty1, ty2, _, _) ->\n (next2 [@ocaml.tailcall]) ty1 ty2 (fst x) (snd x)\n | Union_t (ty1, ty2, _, _) -> (\n match x with\n | L l -> (next [@ocaml.tailcall]) ty1 l\n | R r -> (next [@ocaml.tailcall]) ty2 r)\n | Option_t (ty, _, _) -> (\n match x with\n | None -> return ()\n | Some v -> (next [@ocaml.tailcall]) ty v)\n | Ticket_t (cty, _) -> (aux [@ocaml.tailcall]) accu cty x.contents continue\n | List_t (ty', _) -> on_list ty' accu x.elements\n | Map_t (kty, ty', _) ->\n let (Map_tag (module M)) = x in\n let bindings = M.OPS.fold (fun k v bs -> (k, v) :: bs) M.boxed [] in\n on_bindings accu kty ty' continue bindings\n | Set_t (ty', _) ->\n let (Set_tag (module M)) = x in\n let elements = M.OPS.fold (fun x s -> x :: s) M.boxed [] in\n on_list ty' accu elements\n | Big_map_t (_, _, _) ->\n (* For big maps, there is no obvious recursion scheme so we\n delegate this case to the client. *)\n (return [@ocaml.tailcall]) ()\n | Contract_t (_, _) -> (return [@ocaml.tailcall]) ()\n and on_bindings :\n type ret k v vc.\n 'accu ->\n k comparable_ty ->\n (v, vc) ty ->\n ('accu -> ret) ->\n (k * v) list ->\n ret =\n fun accu kty ty' continue xs ->\n match xs with\n | [] -> (continue [@ocaml.tailcall]) accu\n | (k, v) :: xs ->\n (aux [@ocaml.tailcall]) accu kty k (fun accu ->\n (aux [@ocaml.tailcall]) accu ty' v (fun accu ->\n (on_bindings [@ocaml.tailcall]) accu kty ty' continue xs))\n in\n aux init ty x (fun accu -> accu)\n\nlet stack_top_ty : type a b s. (a, b * s) stack_ty -> a ty_ex_c = function\n | Item_t (ty, _) -> Ty_ex_c ty\n\nmodule Typed_contract = struct\n let destination : type a. a typed_contract -> Destination.t = function\n | Typed_implicit pkh -> Destination.Contract (Implicit pkh)\n | Typed_implicit_with_ticket {destination; _} ->\n Destination.Contract (Implicit destination)\n | Typed_originated {contract_hash; _} ->\n Destination.Contract (Originated contract_hash)\n | Typed_tx_rollup {tx_rollup; _} -> Destination.Tx_rollup tx_rollup\n | Typed_sc_rollup {sc_rollup; _} -> Destination.Sc_rollup sc_rollup\n | Typed_zk_rollup {zk_rollup; _} -> Destination.Zk_rollup zk_rollup\n\n let arg_ty : type a. a typed_contract -> a ty_ex_c = function\n | Typed_implicit _ -> (Ty_ex_c Unit_t : a ty_ex_c)\n | Typed_implicit_with_ticket {ticket_ty; _} -> Ty_ex_c ticket_ty\n | Typed_originated {arg_ty; _} -> Ty_ex_c arg_ty\n | Typed_tx_rollup {arg_ty; _} -> Ty_ex_c arg_ty\n | Typed_sc_rollup {arg_ty; _} -> Ty_ex_c arg_ty\n | Typed_zk_rollup {arg_ty; _} -> Ty_ex_c arg_ty\n\n let entrypoint : type a. a typed_contract -> Entrypoint.t = function\n | Typed_implicit _ | Typed_implicit_with_ticket _ -> Entrypoint.default\n | Typed_tx_rollup _ -> Entrypoint.deposit\n | Typed_originated {entrypoint; _} | Typed_sc_rollup {entrypoint; _} ->\n entrypoint\n | Typed_zk_rollup _ -> Entrypoint.deposit\n\n module Internal_for_tests = struct\n let typed_exn :\n type a ac.\n (a, ac) ty -> Destination.t -> Entrypoint.t -> a typed_contract =\n fun arg_ty destination entrypoint ->\n match (destination, arg_ty) with\n | Contract (Implicit pkh), Unit_t -> Typed_implicit pkh\n | Contract (Implicit _), _ ->\n invalid_arg \"Implicit contracts expect type unit\"\n | Contract (Originated contract_hash), _ ->\n Typed_originated {arg_ty; contract_hash; entrypoint}\n | Tx_rollup tx_rollup, Pair_t (Ticket_t _, Tx_rollup_l2_address_t, _, _)\n ->\n (Typed_tx_rollup {arg_ty; tx_rollup} : a typed_contract)\n | Tx_rollup _, _ ->\n invalid_arg\n \"Transaction rollups expect type (pair (ticket _) \\\n tx_rollup_l2_address)\"\n | Sc_rollup sc_rollup, _ ->\n Typed_sc_rollup {arg_ty; sc_rollup; entrypoint}\n | Zk_rollup zk_rollup, Pair_t (Ticket_t _, Bytes_t, _, _) ->\n (Typed_zk_rollup {arg_ty; zk_rollup} : a typed_contract)\n | Zk_rollup _, _ ->\n invalid_arg \"ZK rollups expect type (pair (ticket _) bytes)\"\n end\nend\n" ;
} ;
{ name = "Script_comparable" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nval compare_comparable : 'a Script_typed_ir.comparable_ty -> 'a -> 'a -> int\n\nval compare_address : Script_typed_ir.address -> Script_typed_ir.address -> int\n\nval compare_tx_rollup_l2_address :\n Script_typed_ir.tx_rollup_l2_address ->\n Script_typed_ir.tx_rollup_l2_address ->\n int\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\nopen Script_typed_ir\n\nlet compare_address {destination = destination1; entrypoint = entrypoint1}\n {destination = destination2; entrypoint = entrypoint2} =\n let lres = Destination.compare destination1 destination2 in\n if Compare.Int.(lres = 0) then Entrypoint.compare entrypoint1 entrypoint2\n else lres\n\nlet compare_tx_rollup_l2_address = Tx_rollup_l2_address.Indexable.compare_values\n\ntype compare_comparable_cont =\n | Compare_comparable :\n 'a comparable_ty * 'a * 'a * compare_comparable_cont\n -> compare_comparable_cont\n | Compare_comparable_return : compare_comparable_cont\n\nlet compare_comparable : type a. a comparable_ty -> a -> a -> int =\n let rec compare_comparable :\n type a. a comparable_ty -> compare_comparable_cont -> a -> a -> int =\n fun kind k x y ->\n match (kind, x, y) with\n | Unit_t, (), () -> (apply [@tailcall]) 0 k\n | Never_t, _, _ -> .\n | Signature_t, x, y -> (apply [@tailcall]) (Script_signature.compare x y) k\n | String_t, x, y -> (apply [@tailcall]) (Script_string.compare x y) k\n | Bool_t, x, y -> (apply [@tailcall]) (Compare.Bool.compare x y) k\n | Mutez_t, x, y -> (apply [@tailcall]) (Tez.compare x y) k\n | Key_hash_t, x, y ->\n (apply [@tailcall]) (Signature.Public_key_hash.compare x y) k\n | Key_t, x, y -> (apply [@tailcall]) (Signature.Public_key.compare x y) k\n | Int_t, x, y -> (apply [@tailcall]) (Script_int.compare x y) k\n | Nat_t, x, y -> (apply [@tailcall]) (Script_int.compare x y) k\n | Timestamp_t, x, y -> (apply [@tailcall]) (Script_timestamp.compare x y) k\n | Address_t, x, y -> (apply [@tailcall]) (compare_address x y) k\n | Tx_rollup_l2_address_t, x, y ->\n (apply [@tailcall]) (compare_tx_rollup_l2_address x y) k\n | Bytes_t, x, y -> (apply [@tailcall]) (Compare.Bytes.compare x y) k\n | Chain_id_t, x, y -> (apply [@tailcall]) (Script_chain_id.compare x y) k\n | Pair_t (tl, tr, _, YesYes), (lx, rx), (ly, ry) ->\n (compare_comparable [@tailcall])\n tl\n (Compare_comparable (tr, rx, ry, k))\n lx\n ly\n | Union_t (tl, _, _, YesYes), L x, L y ->\n (compare_comparable [@tailcall]) tl k x y\n | Union_t _, L _, R _ -> -1\n | Union_t _, R _, L _ -> 1\n | Union_t (_, tr, _, YesYes), R x, R y ->\n (compare_comparable [@tailcall]) tr k x y\n | Option_t _, None, None -> (apply [@tailcall]) 0 k\n | Option_t _, None, Some _ -> -1\n | Option_t _, Some _, None -> 1\n | Option_t (t, _, Yes), Some x, Some y ->\n (compare_comparable [@tailcall]) t k x y\n and apply ret k =\n match (ret, k) with\n | 0, Compare_comparable (ty, x, y, k) ->\n (compare_comparable [@tailcall]) ty k x y\n | 0, Compare_comparable_return -> 0\n | ret, _ ->\n (* ret <> 0, we perform an early exit *)\n if Compare.Int.(ret > 0) then 1 else -1\n in\n fun t -> compare_comparable t Compare_comparable_return\n" ;
} ;
{ name = "Gas_comparable_input_size" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** [Gas_input_size] includes the definitions for the different sizes used\n in the gas models of the protocol. They do not always represent memory\n sizes, but rather they can be seen as an information size. They are\n tailored to the models that use them, and should not be used for anything\n other than gas computation.\n\n [Gas_comparable_input_size] is the restriction of [Gas_input_size] to\n comparable types.\n *)\n\ntype t = int\n\ntype micheline_size = {traversal : t; int_bytes : t; string_bytes : t}\n\n(* ------------------------------------------------------------------------- *)\n(* encoding *)\n\nval encoding : t Data_encoding.encoding\n\nval micheline_size_encoding : micheline_size Data_encoding.encoding\n\n(* ------------------------------------------------------------------------- *)\n\nval zero : t\n\nval add : t -> t -> t\n\nval pp : Format.formatter -> t -> unit\n\nval pp_micheline_size : Format.formatter -> micheline_size -> unit\n\nval to_int : t -> int\n\nval of_int : int -> t\n\nval integer : 'a Script_int.num -> t\n\nval string : string -> t\n\nval script_string : Script_string.t -> t\n\nval bytes : Bytes.t -> t\n\nval mutez : Alpha_context.Tez.tez -> t\n\nval timestamp : Script_timestamp.t -> t\n\nval size_of_comparable_value : 'a Script_typed_ir.comparable_ty -> 'a -> t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype t = int\n\ntype micheline_size = {traversal : t; int_bytes : t; string_bytes : t}\n\n(* ------------------------------------------------------------------------- *)\n(* encoding *)\n\nlet encoding : t Data_encoding.encoding =\n let open Data_encoding in\n conv (fun i -> Int64.of_int i) (fun l -> Int64.to_int l) int64\n\nlet micheline_size_encoding : micheline_size Data_encoding.encoding =\n let open Data_encoding in\n conv\n (fun {traversal; int_bytes; string_bytes} ->\n (traversal, int_bytes, string_bytes))\n (fun (traversal, int_bytes, string_bytes) ->\n {traversal; int_bytes; string_bytes})\n (tup3 encoding encoding encoding)\n\n(* ------------------------------------------------------------------------- *)\n\nlet zero = 0\n\nlet add = ( + )\n\nlet pp = Format.pp_print_int\n\nlet pp_micheline_size fmtr {traversal; int_bytes; string_bytes} =\n Format.fprintf\n fmtr\n \"@[{ traversal = %a;@; int_bytes = %a;@; string_bytes = %a;@,}@]\"\n pp\n traversal\n pp\n int_bytes\n pp\n string_bytes\n\nlet to_int x = x\n\nlet of_int x = x\n\nlet unit : t = 1\n\nlet integer (i : 'a Script_int.num) : t = Z.numbits (Script_int.to_zint i) / 8\n\nlet string = String.length\n\nlet script_string = Script_string.length\n\nlet bytes (b : Bytes.t) : t = Bytes.length b\n\nlet mutez (_tez : Alpha_context.Tez.tez) : t =\n (* Up to now, mutez are stored on 8 bytes (int64). *)\n 8\n\nlet bool (_ : bool) : t = 1\n\nlet signature (signature : Script_typed_ir.Script_signature.t) : t =\n Script_typed_ir.Script_signature.size signature\n\nlet key_hash (_keyhash : Signature.public_key_hash) : t =\n Signature.Public_key_hash.size\n\nlet public_key (public_key : Signature.public_key) : t =\n Signature.Public_key.size public_key\n\nlet chain_id (_chain_id : Script_typed_ir.Script_chain_id.t) : t =\n Script_typed_ir.Script_chain_id.size\n\nlet address (addr : Script_typed_ir.address) : t =\n let entrypoint = addr.entrypoint in\n Signature.Public_key_hash.size\n + String.length (Alpha_context.Entrypoint.to_string entrypoint)\n\nlet tx_rollup_l2_address x =\n Tx_rollup_l2_address.Indexable.size @@ Indexable.forget x\n\nlet timestamp (tstamp : Script_timestamp.t) : t =\n Z.numbits (Script_timestamp.to_zint tstamp) / 8\n\nlet rec size_of_comparable_value :\n type a. a Script_typed_ir.comparable_ty -> a -> t =\n fun (type a) (wit : a Script_typed_ir.comparable_ty) (v : a) ->\n match wit with\n | Never_t -> ( match v with _ -> .)\n | Unit_t -> unit\n | Int_t -> integer v\n | Nat_t -> integer v\n | String_t -> script_string v\n | Bytes_t -> bytes v\n | Mutez_t -> mutez v\n | Bool_t -> bool v\n | Key_hash_t -> key_hash v\n | Timestamp_t -> timestamp v\n | Address_t -> address v\n | Tx_rollup_l2_address_t -> tx_rollup_l2_address v\n | Pair_t (leaf, node, _, YesYes) ->\n let lv, rv = v in\n let size =\n size_of_comparable_value leaf lv + size_of_comparable_value node rv\n in\n size + 1\n | Union_t (left, right, _, YesYes) ->\n let size =\n match v with\n | L v -> size_of_comparable_value left v\n | R v -> size_of_comparable_value right v\n in\n size + 1\n | Option_t (ty, _, Yes) -> (\n match v with None -> 1 | Some x -> size_of_comparable_value ty x + 1)\n | Signature_t -> signature v\n | Key_t -> public_key v\n | Chain_id_t -> chain_id v\n" ;
} ;
{ name = "Script_set" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Functions to ease the manipulation of sets of values in Michelson.\n\n A set in Michelson is a collection of type-homegeneous values along with the\n functions that operate on the structure (through a first-class module). In\n particular, the {!size} function runs in constant time.\n*)\n\nopen Script_typed_ir\n\nval make : (module Boxed_set with type elt = 'elt) -> 'elt set\n\nval get : 'elt set -> (module Boxed_set with type elt = 'elt)\n\n(** [empty cmp_ty] creates a set module where elements have size\n [Gas_comparable_input_size.size_of_comparable_value cmp_ty] and are compared\n with [Script_comparable.compare_comparable cmp_ty] (used for sorting values,\n which ensures a reasonable complexity of the set functions).\n The function returns an empty set packaged as a first-class set module. *)\nval empty : 'a comparable_ty -> 'a set\n\nval fold : ('elt -> 'acc -> 'acc) -> 'elt set -> 'acc -> 'acc\n\n(** [update v true set] adds [v] to [set], and [update v false set] removes [v]\n from [set]. *)\nval update : 'a -> bool -> 'a set -> 'a set\n\nval mem : 'elt -> 'elt set -> bool\n\n(** [size set] runs in constant time. *)\nval size : 'elt set -> Script_int.n Script_int.num\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Script_typed_ir\n\nlet make x = Set_tag x\n\nlet get (Set_tag x) = x\n\nlet empty : type a. a comparable_ty -> a set =\n fun ty ->\n let module OPS : Boxed_set_OPS with type elt = a = struct\n let elt_size = Gas_comparable_input_size.size_of_comparable_value ty\n\n include Set.Make (struct\n type t = a\n\n let compare = Script_comparable.compare_comparable ty\n end)\n end in\n Set_tag\n (module struct\n type elt = a\n\n module OPS = OPS\n\n let boxed = OPS.empty\n\n let size = 0\n end)\n\nlet update : type a. a -> bool -> a set -> a set =\n fun v b (Set_tag (module Box)) ->\n Set_tag\n (module struct\n type elt = a\n\n module OPS = Box.OPS\n\n let boxed =\n if b then Box.OPS.add v Box.boxed else Box.OPS.remove v Box.boxed\n\n let size =\n let mem = Box.OPS.mem v Box.boxed in\n if mem then if b then Box.size else Box.size - 1\n else if b then Box.size + 1\n else Box.size\n end)\n\nlet mem : type elt. elt -> elt set -> bool =\n fun v (Set_tag (module Box)) -> Box.OPS.mem v Box.boxed\n\nlet fold : type elt acc. (elt -> acc -> acc) -> elt set -> acc -> acc =\n fun f (Set_tag (module Box)) -> Box.OPS.fold f Box.boxed\n\nlet size : type elt. elt set -> Script_int.n Script_int.num =\n fun (Set_tag (module Box)) -> Script_int.(abs (of_int Box.size))\n" ;
} ;
{ name = "Script_map" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Functions to ease the manipulation of Michelson maps.\n\n A map in Michelson is a type-homegeneous, partial function of keys to\n values, along with the functions that operate on the structure (through a\n first-class module).\n*)\n\nopen Script_typed_ir\n\nval make :\n (module Boxed_map with type key = 'key and type value = 'value) ->\n ('key, 'value) map\n\nval get_module :\n ('key, 'value) map ->\n (module Boxed_map with type key = 'key and type value = 'value)\n\n(** [empty cmp_ty] creates a map module where keys have size\n [Gas_comparable_input_size.size_of_comparable_value cmp_ty] and are compared\n with [Script_comparable.compare_comparable cmp_ty] (used for sorting keys,\n which ensures a reasonable complexity of the map functions).\n The function returns an empty map packaged as a first-class map module. *)\nval empty : 'a comparable_ty -> ('a, 'b) map\n\n(** [empty_from map] creates an empty map module where the size of keys and the\n comparison function are those of [map]. *)\nval empty_from : ('a, 'b) map -> ('a, 'c) map\n\nval fold :\n ('key -> 'value -> 'acc -> 'acc) -> ('key, 'value) map -> 'acc -> 'acc\n\nval fold_es :\n ('key -> 'value -> 'acc -> 'acc tzresult Lwt.t) ->\n ('key, 'value) map ->\n 'acc ->\n 'acc tzresult Lwt.t\n\n(** [update k (Some v) map] associates [v] to [k] in [map] (overwriting the\n previous value, if any), and [update k None map] removes the potential\n association to [k] in [map]. *)\nval update : 'a -> 'b option -> ('a, 'b) map -> ('a, 'b) map\n\nval mem : 'key -> ('key, 'value) map -> bool\n\nval get : 'key -> ('key, 'value) map -> 'value option\n\nval size : ('a, 'b) map -> Script_int.n Script_int.num\n\nval map_es_in_context :\n ('context -> 'key -> 'value1 -> ('value2 * 'context) tzresult Lwt.t) ->\n 'context ->\n ('key, 'value1) map ->\n (('key, 'value2) map * 'context) tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Script_typed_ir\n\nlet make x = Map_tag x\n\nlet get_module (Map_tag x) = x\n\nlet empty_from : type a b c. (a, b) map -> (a, c) map =\n fun (Map_tag (module Box)) ->\n Map_tag\n (module struct\n type key = a\n\n type value = c\n\n module OPS = Box.OPS\n\n let boxed = OPS.empty\n\n let size = 0\n end)\n\nlet empty : type a b. a comparable_ty -> (a, b) map =\n fun ty ->\n let module OPS = struct\n let key_size = Gas_comparable_input_size.size_of_comparable_value ty\n\n include Map.Make (struct\n type t = a\n\n let compare = Script_comparable.compare_comparable ty\n end)\n end in\n Map_tag\n (module struct\n type key = a\n\n type value = b\n\n module OPS = OPS\n\n let boxed = OPS.empty\n\n let size = 0\n end)\n\nlet get : type key value. key -> (key, value) map -> value option =\n fun k (Map_tag (module Box)) -> Box.OPS.find k Box.boxed\n\nlet update : type a b. a -> b option -> (a, b) map -> (a, b) map =\n fun k v (Map_tag (module Box)) ->\n let boxed, size =\n let contains =\n match Box.OPS.find k Box.boxed with None -> false | _ -> true\n in\n match v with\n | Some v -> (Box.OPS.add k v Box.boxed, Box.size + if contains then 0 else 1)\n | None -> (Box.OPS.remove k Box.boxed, Box.size - if contains then 1 else 0)\n in\n Map_tag\n (module struct\n type key = a\n\n type value = b\n\n module OPS = Box.OPS\n\n let boxed = boxed\n\n let size = size\n end)\n\nlet mem : type key value. key -> (key, value) map -> bool =\n fun k (Map_tag (module Box)) ->\n match Box.OPS.find k Box.boxed with None -> false | _ -> true\n\nlet fold :\n type key value acc.\n (key -> value -> acc -> acc) -> (key, value) map -> acc -> acc =\n fun f (Map_tag (module Box)) -> Box.OPS.fold f Box.boxed\n\nlet fold_es :\n type key value acc.\n (key -> value -> acc -> acc tzresult Lwt.t) ->\n (key, value) map ->\n acc ->\n acc tzresult Lwt.t =\n fun f (Map_tag (module Box)) -> Box.OPS.fold_es f Box.boxed\n\nlet size : type key value. (key, value) map -> Script_int.n Script_int.num =\n fun (Map_tag (module Box)) -> Script_int.(abs (of_int Box.size))\n\nlet map_es_in_context :\n type context key value value'.\n (context -> key -> value -> (value' * context) tzresult Lwt.t) ->\n context ->\n (key, value) map ->\n ((key, value') map * context) tzresult Lwt.t =\n fun f ctxt (Map_tag (module Box)) ->\n Box.OPS.fold_es\n (fun key value (map, ctxt) ->\n f ctxt key value >|=? fun (value, ctxt) ->\n (Box.OPS.add key value map, ctxt))\n Box.boxed\n (Box.OPS.empty, ctxt)\n >|=? fun (map, ctxt) ->\n ( Map_tag\n (module struct\n type key = Box.key\n\n type value = value'\n\n module OPS = Box.OPS\n\n let boxed = map\n\n let size = Box.size\n end),\n ctxt )\n" ;
} ;
{ name = "Gas_input_size" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** [Gas_input_size] includes the definitions for the different sizes used\n in the gas models of the protocol. They do not always represent memory\n sizes, but rather they can be seen as an information size. They are\n tailored to the models that use them, and should not be used for anything\n other than gas computation.\n *)\n\ninclude module type of Gas_comparable_input_size\n\n(* ------------------------------------------------------------------------- *)\n\nval list : 'a Script_list.t -> t\n\nval set : 'a Script_typed_ir.set -> t\n\nval map : ('a, 'b) Script_typed_ir.map -> t\n\n(* ------------------------------------------------------------------------- *)\n(* Micheline/Michelson-related *)\n\nval of_micheline : ('a, 'b) Micheline.node -> micheline_size\n\n(* ------------------------------------------------------------------------- *)\n(* Sapling-related *)\n\nval sapling_transaction_inputs : Alpha_context.Sapling.transaction -> t\n\nval sapling_transaction_outputs : Alpha_context.Sapling.transaction -> t\n\nval sapling_transaction_bound_data : Alpha_context.Sapling.transaction -> t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ninclude Gas_comparable_input_size\n\nlet list (list : 'a Script_list.t) : t = list.Script_list.length\n\nlet set (set : 'a Script_typed_ir.set) : t =\n let res = Script_int.to_int (Script_set.size set) in\n match res with None -> assert false | Some x -> x\n\nlet map (map : ('a, 'b) Script_typed_ir.map) : t =\n let res = Script_int.to_int (Script_map.size map) in\n match res with None -> assert false | Some x -> x\n\n(* ------------------------------------------------------------------------- *)\n(* Micheline/Michelson-related *)\n\nlet micheline_zero = {traversal = 0; int_bytes = 0; string_bytes = 0}\n\nlet ( ++ ) x y =\n {\n traversal = x.traversal + y.traversal;\n int_bytes = x.int_bytes + y.int_bytes;\n string_bytes = x.string_bytes + y.string_bytes;\n }\n\nlet node leaves =\n let r = List.fold_left ( ++ ) micheline_zero leaves in\n {r with traversal = r.traversal + 1}\n\nlet rec of_micheline (x : ('a, 'b) Micheline.node) =\n match x with\n | Micheline.Int (_loc, z) ->\n let int_bytes = integer (Script_int.of_zint z) in\n {traversal = 1; int_bytes; string_bytes = 0}\n | Micheline.String (_loc, s) ->\n let string_bytes = String.length s in\n {traversal = 1; int_bytes = 0; string_bytes}\n | Micheline.Bytes (_loc, b) ->\n let string_bytes = bytes b in\n {traversal = 1; int_bytes = 0; string_bytes}\n | Micheline.Prim (_loc, _prim, subterms, _annot) ->\n node (List.map of_micheline subterms)\n | Micheline.Seq (_loc, subterms) -> node (List.map of_micheline subterms)\n\n(* ------------------------------------------------------------------------- *)\n(* Sapling-related *)\n\nlet sapling_transaction_inputs : Alpha_context.Sapling.transaction -> t =\n fun tx -> List.length tx.inputs\n\nlet sapling_transaction_outputs : Alpha_context.Sapling.transaction -> t =\n fun tx -> List.length tx.outputs\n\nlet sapling_transaction_bound_data : Alpha_context.Sapling.transaction -> t =\n fun tx -> String.length tx.bound_data\n" ;
} ;
{ name = "Script_typed_ir_size" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module provides overapproximation of memory footprint for\n Michelson-related values.\n\n These overapproximations are used by the cache to evaluate its own\n memory footprint and enforce declared limit over its size.\n\n*)\n\n(** [value_size ty v] returns an overapproximation of the size of the\n in-memory representation of [v] of type [ty]. *)\nval value_size :\n ('a, _) Script_typed_ir.ty -> 'a -> Cache_memory_helpers.nodes_and_size\n\n(** [lambda_size l] returns an overapproximation of the size of the\n internal IR for the Michelson lambda abstraction [l]. *)\nval lambda_size :\n ('a, 'b) Script_typed_ir.lambda -> Cache_memory_helpers.nodes_and_size\n\n(** [node_size root] returns the size of the in-memory representation\n of [root] in bytes. This is an over-approximation of the memory\n actually consumed by [root] since no sharing is taken into\n account. *)\nval node_size :\n ('loc, 'prim) Micheline.node -> Cache_memory_helpers.nodes_and_size\n\n(** Pointwise addition (reexport from {!Cache_memory_helpers}) *)\nval ( ++ ) :\n Cache_memory_helpers.nodes_and_size ->\n Cache_memory_helpers.nodes_and_size ->\n Cache_memory_helpers.nodes_and_size\n\n(** Zero vector (reexport from {!Cache_memory_helpers}) *)\nval zero : Cache_memory_helpers.nodes_and_size\n\n(**/**)\n\nmodule Internal_for_tests : sig\n (** [ty_size ty] returns an overapproximation of the size of the\n in-memory representation of type [ty]. *)\n val ty_size :\n ('a, _) Script_typed_ir.ty -> Cache_memory_helpers.nodes_and_size\n\n (** [kinstr_size i] returns an overapproximation of the size of the\n internal IR [i]. *)\n val kinstr_size :\n ('a, 's, 'r, 'f) Script_typed_ir.kinstr ->\n Cache_memory_helpers.nodes_and_size\n\n val stack_prefix_preservation_witness_size :\n ( 'a,\n 'b,\n 'c,\n 'd,\n 'e,\n 'f,\n 'g,\n 'h )\n Script_typed_ir.stack_prefix_preservation_witness ->\n Cache_memory_helpers.nodes_and_size\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\nopen Script_typed_ir\ninclude Cache_memory_helpers\n\nlet script_string_size s = Script_string.to_string s |> string_size\n\nlet ty_traverse_f =\n let base_basic =\n !!0\n (* Basic types count for 0 because they are all static values, hence shared\n and not counted by `reachable_words`.\n On the other hand compound types are functions, hence not shared. *)\n in\n let base_compound_no_meta = header_size in\n let base_compound _meta = h1w in\n let apply : type a ac. nodes_and_size -> (a, ac) ty -> nodes_and_size =\n fun accu ty ->\n match ty with\n | Unit_t -> ret_succ_adding accu base_basic\n | Int_t -> ret_succ_adding accu base_basic\n | Nat_t -> ret_succ_adding accu base_basic\n | Signature_t -> ret_succ_adding accu base_basic\n | String_t -> ret_succ_adding accu base_basic\n | Bytes_t -> ret_succ_adding accu base_basic\n | Mutez_t -> ret_succ_adding accu base_basic\n | Key_hash_t -> ret_succ_adding accu base_basic\n | Key_t -> ret_succ_adding accu base_basic\n | Timestamp_t -> ret_succ_adding accu base_basic\n | Address_t -> ret_succ_adding accu base_basic\n | Tx_rollup_l2_address_t -> ret_succ_adding accu base_basic\n | Bool_t -> ret_succ_adding accu base_basic\n | Operation_t -> ret_succ_adding accu base_basic\n | Chain_id_t -> ret_succ_adding accu base_basic\n | Never_t -> ret_succ_adding accu base_basic\n | Bls12_381_g1_t -> ret_succ_adding accu base_basic\n | Bls12_381_g2_t -> ret_succ_adding accu base_basic\n | Bls12_381_fr_t -> ret_succ_adding accu base_basic\n | Chest_key_t -> ret_succ_adding accu base_basic\n | Chest_t -> ret_succ_adding accu base_basic\n | Pair_t (_ty1, _ty2, a, _) ->\n ret_succ_adding accu @@ (base_compound a +! (word_size *? 3))\n | Union_t (_ty1, _ty2, a, _) ->\n ret_succ_adding accu @@ (base_compound a +! (word_size *? 3))\n | Lambda_t (_ty1, _ty2, a) ->\n ret_succ_adding accu @@ (base_compound a +! (word_size *? 2))\n | Option_t (_ty, a, _) ->\n ret_succ_adding accu @@ (base_compound a +! (word_size *? 2))\n | List_t (_ty, a) -> ret_succ_adding accu @@ (base_compound a +! word_size)\n | Set_t (_cty, a) -> ret_succ_adding accu @@ (base_compound a +! word_size)\n | Map_t (_cty, _ty, a) ->\n ret_succ_adding accu @@ (base_compound a +! (word_size *? 2))\n | Big_map_t (_cty, _ty, a) ->\n ret_succ_adding accu @@ (base_compound a +! (word_size *? 2))\n | Contract_t (_ty, a) ->\n ret_succ_adding accu @@ (base_compound a +! word_size)\n | Sapling_transaction_t m ->\n ret_succ_adding accu\n @@ base_compound_no_meta\n +! Sapling.Memo_size.in_memory_size m\n +! word_size\n | Sapling_transaction_deprecated_t m ->\n ret_succ_adding accu\n @@ base_compound_no_meta\n +! Sapling.Memo_size.in_memory_size m\n +! word_size\n | Sapling_state_t m ->\n ret_succ_adding accu\n @@ base_compound_no_meta\n +! Sapling.Memo_size.in_memory_size m\n +! word_size\n | Ticket_t (_cty, a) ->\n ret_succ_adding accu @@ (base_compound a +! word_size)\n in\n ({apply} : nodes_and_size ty_traverse)\n\nlet ty_size : type a ac. (a, ac) ty -> nodes_and_size =\n fun ty -> ty_traverse ty zero ty_traverse_f\n\n(* Types stored for logging are optional and never present in the cache. Therefore\n it's safe not to count them. *)\nlet ty_for_logging_size : type a ac. (a, ac) ty option -> sint = fun _ty -> !!0\n\nlet stack_ty_size s =\n let apply : type a s. nodes_and_size -> (a, s) stack_ty -> nodes_and_size =\n fun accu s ->\n match s with\n | Bot_t -> ret_succ accu\n | Item_t (ty, _) -> ret_succ_adding (accu ++ ty_size ty) h2w\n in\n stack_ty_traverse s zero {apply}\n\n(* Stack types for logging are optional and never present in the cache. Therefore\n it's safe not to count them. One word taken by the [None] tag is already\n accounted for by the call-sites of this function. *)\nlet stack_ty_for_logging_size : type a s. (a, s) stack_ty option -> sint =\n fun _ -> !!0\n\nlet script_nat_size n = Script_int.to_zint n |> z_size\n\nlet script_int_size n = Script_int.to_zint n |> z_size\n\nlet signature_size (Script_signature.Signature_tag x) =\n match x with\n (* By Obj.reachable_words. *)\n | Ed25519 _ | Secp256k1 _ | P256 _ | Unknown _ -> !!96\n | Bls _ -> !!128\n\nlet key_hash_size (_x : Signature.public_key_hash) = !!64\n(* By Obj.reachable_words. *)\n\nlet public_key_size (x : public_key) =\n h1w\n +?\n match x with\n | Ed25519 _ -> 64\n | Secp256k1 _ -> 72\n | P256 _ -> 96\n | Bls _ -> 64\n\nlet mutez_size = h2w\n\nlet timestamp_size x = Script_timestamp.to_zint x |> z_size\n\nlet destination_size = Destination.in_memory_size\n\nlet address_size addr =\n h2w\n +! destination_size addr.destination\n +! Entrypoint.in_memory_size addr.entrypoint\n\nlet tx_rollup_l2_address_size (tx : tx_rollup_l2_address) =\n Tx_rollup_l2_address.Indexable.in_memory_size @@ Indexable.forget tx\n\nlet view_signature_size (View_signature {name; input_ty; output_ty}) =\n ret_adding\n (ty_size input_ty ++ ty_size output_ty)\n (h3w +! script_string_size name)\n\nlet script_expr_hash_size = !!64\n\n(* Note: this function is NOT tail-recursive, but that's okay, since\n the recursion is bound by the size of the witness, which is an\n 11-bit unsigned integer, i.e. at most 2048. This is enough to\n guarantee there will be no stack overflow. *)\nlet rec stack_prefix_preservation_witness_size_internal :\n type a b c d e f g h.\n (a, b, c, d, e, f, g, h) stack_prefix_preservation_witness -> nodes_and_size\n = function\n | KPrefix (_loc, ty, w) ->\n ret_succ_adding\n (ty_size ty ++ stack_prefix_preservation_witness_size_internal w)\n h3w\n | KRest -> zero\n\nlet stack_prefix_preservation_witness_size (_n : int) w =\n stack_prefix_preservation_witness_size_internal w\n\nlet peano_shape_proof =\n let scale = header_size +! h1w in\n fun k -> scale *? k\n\nlet comb_gadt_witness_size n (_w : (_, _, _, _, _, _) comb_gadt_witness) =\n peano_shape_proof n\n\nlet uncomb_gadt_witness_size n (_w : (_, _, _, _, _, _) uncomb_gadt_witness) =\n peano_shape_proof n\n\nlet comb_get_gadt_witness_size n (_w : (_, _) comb_get_gadt_witness) =\n peano_shape_proof n\n\nlet comb_set_gadt_witness_size n (_w : (_, _, _) comb_set_gadt_witness) =\n peano_shape_proof n\n\nlet dup_n_gadt_witness_size n (_w : (_, _, _, _) dup_n_gadt_witness) =\n peano_shape_proof n\n\nlet contract_size : type t. t typed_contract -> nodes_and_size = function\n | Typed_implicit _ -> ret_adding zero (h1w +! public_key_hash_in_memory_size)\n | Typed_implicit_with_ticket {ticket_ty; destination = _} ->\n ret_adding (ty_size ticket_ty) (h2w +! public_key_hash_in_memory_size)\n | Typed_originated {arg_ty; contract_hash = _; entrypoint} ->\n ret_adding\n (ty_size arg_ty)\n (h3w +! blake2b_hash_size +! Entrypoint.in_memory_size entrypoint)\n | Typed_tx_rollup {arg_ty; tx_rollup} ->\n ret_adding (ty_size arg_ty) (h2w +! Tx_rollup.in_memory_size tx_rollup)\n | Typed_sc_rollup {arg_ty; sc_rollup; entrypoint} ->\n ret_adding\n (ty_size arg_ty)\n (h3w\n +! Sc_rollup.in_memory_size sc_rollup\n +! Entrypoint.in_memory_size entrypoint)\n | Typed_zk_rollup {arg_ty; zk_rollup} ->\n ret_adding (ty_size arg_ty) (h2w +! Zk_rollup.in_memory_size zk_rollup)\n\nlet sapling_state_size {Sapling.id; diff; memo_size} =\n h3w\n +! option_size (fun x -> z_size (Sapling.Id.unparse_to_z x)) id\n +! Sapling.diff_in_memory_size diff\n +! Sapling.Memo_size.in_memory_size memo_size\n\nlet chain_id_size = !!16 (* by Obj.reachable_words. *)\n\n(* [contents] is handled by the recursion scheme in [value_size]. *)\nlet ticket_size {ticketer; contents = _; amount} =\n h3w\n +! Contract.in_memory_size ticketer\n +! script_nat_size (amount :> Script_int.n Script_int.num)\n\nlet chest_size chest =\n (*\n type chest = {\n locked_value : locked_value;\n rsa_public : rsa_public;\n ciphertext : ciphertext;\n }\n *)\n let locked_value_size = 256 in\n let rsa_public_size = 256 in\n let ciphertext_size = Script_timelock.get_plaintext_size chest in\n h3w +? (locked_value_size + rsa_public_size + ciphertext_size)\n\nlet chest_key_size _ =\n (*\n type chest_key = {\n unlocked_value : unlocked_value;\n proof : time_lock_proof\n }\n *)\n let unlocked_value_size = 256 in\n let proof_size = 256 in\n h2w +? (unlocked_value_size + proof_size)\n\n(* The following mutually recursive functions are mostly\n tail-recursive and the only recursive call that is not a tailcall\n cannot be nested. (See [big_map_size].) For this reason, these\n functions should not trigger stack overflows. *)\nlet rec value_size :\n type a ac.\n count_lambda_nodes:bool ->\n nodes_and_size ->\n (a, ac) ty ->\n a ->\n nodes_and_size =\n fun ~count_lambda_nodes accu ty x ->\n let apply : type a ac. nodes_and_size -> (a, ac) ty -> a -> nodes_and_size =\n fun accu ty x ->\n match ty with\n | Unit_t -> ret_succ accu\n | Int_t -> ret_succ_adding accu (script_int_size x)\n | Nat_t -> ret_succ_adding accu (script_nat_size x)\n | Signature_t -> ret_succ_adding accu (signature_size x)\n | String_t -> ret_succ_adding accu (script_string_size x)\n | Bytes_t -> ret_succ_adding accu (bytes_size x)\n | Mutez_t -> ret_succ_adding accu mutez_size\n | Key_hash_t -> ret_succ_adding accu (key_hash_size x)\n | Key_t -> ret_succ_adding accu (public_key_size x)\n | Timestamp_t -> ret_succ_adding accu (timestamp_size x)\n | Address_t -> ret_succ_adding accu (address_size x)\n | Tx_rollup_l2_address_t ->\n ret_succ_adding accu (tx_rollup_l2_address_size x)\n | Bool_t -> ret_succ accu\n | Pair_t (_, _, _, _) -> ret_succ_adding accu h2w\n | Union_t (_, _, _, _) -> ret_succ_adding accu h1w\n | Lambda_t (_, _, _) ->\n (lambda_size [@ocaml.tailcall]) ~count_lambda_nodes (ret_succ accu) x\n | Option_t (_, _, _) -> ret_succ_adding accu (option_size (fun _ -> !!0) x)\n | List_t (_, _) -> ret_succ_adding accu (h2w +! (h2w *? x.length))\n | Set_t (_, _) ->\n let module M = (val Script_set.get x) in\n let boxing_space = !!536 (* By Obj.reachable_words. *) in\n ret_succ_adding accu (boxing_space +! (h4w *? M.size))\n | Map_t (_, _, _) ->\n let module M = (val Script_map.get_module x) in\n let boxing_space = !!696 (* By Obj.reachable_words. *) in\n ret_succ_adding accu (boxing_space +! (h5w *? M.size))\n | Big_map_t (cty, ty', _) ->\n (big_map_size [@ocaml.tailcall])\n ~count_lambda_nodes\n (ret_succ accu)\n cty\n ty'\n x\n | Contract_t (_, _) -> ret_succ (accu ++ contract_size x)\n | Sapling_transaction_t _ ->\n ret_succ_adding accu (Sapling.transaction_in_memory_size x)\n | Sapling_transaction_deprecated_t _ ->\n ret_succ_adding accu (Sapling.Legacy.transaction_in_memory_size x)\n | Sapling_state_t _ -> ret_succ_adding accu (sapling_state_size x)\n (* Operations are neither storable nor pushable, so they can appear neither\n in the storage nor in the script. Hence they cannot appear in the cache\n and we never need to measure their size. *)\n | Operation_t -> assert false\n | Chain_id_t -> ret_succ_adding accu chain_id_size\n | Never_t -> ( match x with _ -> .)\n | Bls12_381_g1_t -> ret_succ_adding accu !!Bls.Primitive.G1.size_in_memory\n | Bls12_381_g2_t -> ret_succ_adding accu !!Bls.Primitive.G2.size_in_memory\n | Bls12_381_fr_t -> ret_succ_adding accu !!Bls.Primitive.Fr.size_in_memory\n | Ticket_t (_, _) -> ret_succ_adding accu (ticket_size x)\n | Chest_key_t -> ret_succ_adding accu (chest_key_size x)\n | Chest_t -> ret_succ_adding accu (chest_size x)\n in\n value_traverse ty x accu {apply}\n\nand big_map_size :\n type a b bc.\n count_lambda_nodes:bool ->\n nodes_and_size ->\n a comparable_ty ->\n (b, bc) ty ->\n (a, b) big_map ->\n nodes_and_size =\n fun ~count_lambda_nodes accu cty ty' (Big_map {id; diff; key_type; value_type}) ->\n (* [Map.bindings] cannot overflow and only consumes a\n logarithmic amount of stack. *)\n let diff_size =\n let map_size =\n Big_map_overlay.fold\n (fun _key_hash (key, value) accu ->\n let base = h5w +! (word_size *? 3) +! script_expr_hash_size in\n let accu = ret_succ_adding accu base in\n (* The following recursive call cannot introduce a stack\n overflow because this would require a key of type\n big_map while big_map is not comparable. *)\n let accu = value_size ~count_lambda_nodes accu cty key in\n match value with\n | None -> accu\n | Some value ->\n let accu = ret_succ_adding accu h1w in\n (value_size [@ocaml.tailcall]) ~count_lambda_nodes accu ty' value)\n diff.map\n accu\n in\n ret_adding map_size h2w\n in\n let big_map_id_size s = z_size (Big_map.Id.unparse_to_z s) in\n let id_size = option_size big_map_id_size id in\n ret_adding\n (ty_size key_type ++ ty_size value_type ++ diff_size)\n (h4w +! id_size)\n\nand lambda_size :\n type i o.\n count_lambda_nodes:bool -> nodes_and_size -> (i, o) lambda -> nodes_and_size\n =\n fun ~count_lambda_nodes accu lam ->\n let count_lambda_body kdescr node =\n (* We assume that the nodes' size have already been counted if the\n lambda is not a toplevel lambda. *)\n let accu =\n ret_adding\n (accu ++ if count_lambda_nodes then node_size node else zero)\n h2w\n in\n (kdescr_size [@ocaml.tailcall]) ~count_lambda_nodes:false accu kdescr\n in\n match lam with\n | Lam (kdescr, node) -> count_lambda_body kdescr node\n | LamRec (kdescr, node) -> count_lambda_body kdescr node\n\nand kdescr_size :\n type a s r f.\n count_lambda_nodes:bool ->\n nodes_and_size ->\n (a, s, r, f) kdescr ->\n nodes_and_size =\n fun ~count_lambda_nodes accu {kloc = _; kbef; kaft; kinstr} ->\n let accu =\n ret_adding (accu ++ stack_ty_size kbef ++ stack_ty_size kaft) h4w\n in\n (kinstr_size [@ocaml.tailcall]) ~count_lambda_nodes accu kinstr\n\nand kinstr_size :\n type a s r f.\n count_lambda_nodes:bool ->\n nodes_and_size ->\n (a, s, r, f) kinstr ->\n nodes_and_size =\n fun ~count_lambda_nodes accu t ->\n (* To avoid forgetting counting things, the [apply] function below must ignore\n no values (can be checked by grepping \\b_\\w*\\b), except for the [ILog] case.\n Use the [base] function depending on the number of continuations in the\n instruction and only count other fields.\n Location counts as zero because it's an immediate integer.\n Continuations are counted by the [kinstr_traverse] function.\n *)\n let base0 (_loc : Script.location) = h1w in\n let base1 (_loc : Script.location) (_k : (_, _, _, _) kinstr) = h2w in\n let base2 (_loc : Script.location) (_k1 : (_, _, _, _) kinstr)\n (_k2 : (_, _, _, _) kinstr) =\n h3w\n in\n let base3 (_loc : Script.location) (_k1 : (_, _, _, _) kinstr)\n (_k2 : (_, _, _, _) kinstr) (_k3 : (_, _, _, _) kinstr) =\n h4w\n in\n let apply :\n type a s r f. nodes_and_size -> (a, s, r, f) kinstr -> nodes_and_size =\n fun accu t ->\n match t with\n | IDrop (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IDup (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ISwap (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IConst (loc, ty, x, k) ->\n let accu = ret_succ_adding accu (base1 loc k +! (word_size *? 2)) in\n (value_size [@ocaml.tailcall])\n ~count_lambda_nodes\n (accu ++ ty_size ty)\n ty\n x\n | ICons_pair (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ICar (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ICdr (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IUnpair (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ICons_some (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ICons_none (loc, ty, k) ->\n ret_succ_adding (accu ++ ty_size ty) (base1 loc k +! word_size)\n | IIf_none {loc; branch_if_none = k1; branch_if_some = k2; k = k3} ->\n ret_succ_adding accu (base3 loc k1 k2 k3)\n | IOpt_map {loc; body = k1; k = k2} ->\n ret_succ_adding accu (base2 loc k1 k2)\n | ICons_left (loc, ty, k) ->\n ret_succ_adding (accu ++ ty_size ty) (base1 loc k +! word_size)\n | ICons_right (loc, ty, k) ->\n ret_succ_adding (accu ++ ty_size ty) (base1 loc k +! word_size)\n | IIf_left {loc; branch_if_left = k1; branch_if_right = k2; k = k3} ->\n ret_succ_adding accu (base3 loc k1 k2 k3)\n | ICons_list (loc, k) -> ret_succ_adding accu (base1 loc k)\n | INil (loc, ty, k) ->\n ret_succ_adding (accu ++ ty_size ty) (base1 loc k +! word_size)\n | IIf_cons {loc; branch_if_nil = k1; branch_if_cons = k2; k = k3} ->\n ret_succ_adding accu (base3 loc k1 k2 k3)\n | IList_map (loc, k1, ty, k2) ->\n ret_succ_adding\n accu\n (base2 loc k1 k2 +! ty_for_logging_size ty +! word_size)\n | IList_iter (loc, ty, k1, k2) ->\n ret_succ_adding\n accu\n (base2 loc k1 k2 +! ty_for_logging_size ty +! word_size)\n | IList_size (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IEmpty_set (loc, cty, k) ->\n ret_succ_adding (accu ++ ty_size cty) (base1 loc k +! word_size)\n | ISet_iter (loc, ty, k1, k2) ->\n ret_succ_adding\n accu\n (base2 loc k1 k2 +! ty_for_logging_size ty +! word_size)\n | ISet_mem (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ISet_update (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ISet_size (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IEmpty_map (loc, cty, vty, k) ->\n ret_succ_adding\n (accu ++ ty_size cty)\n (base1 loc k +! ty_for_logging_size vty +! (word_size *? 2))\n | IMap_map (loc, ty, k1, k2) ->\n ret_succ_adding\n accu\n (base2 loc k1 k2 +! ty_for_logging_size ty +! word_size)\n | IMap_iter (loc, kvty, k1, k2) ->\n ret_succ_adding\n accu\n (base2 loc k1 k2 +! ty_for_logging_size kvty +! word_size)\n | IMap_mem (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IMap_get (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IMap_update (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IMap_get_and_update (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IMap_size (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IEmpty_big_map (loc, cty, ty, k) ->\n ret_succ_adding\n (accu ++ ty_size cty ++ ty_size ty)\n (base1 loc k +! (word_size *? 2))\n | IBig_map_mem (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IBig_map_get (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IBig_map_update (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IBig_map_get_and_update (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IConcat_string (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IConcat_string_pair (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ISlice_string (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IString_size (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IConcat_bytes (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IConcat_bytes_pair (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ISlice_bytes (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IBytes_size (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ILsl_bytes (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ILsr_bytes (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IOr_bytes (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IAnd_bytes (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IXor_bytes (loc, k) -> ret_succ_adding accu (base1 loc k)\n | INot_bytes (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IBytes_nat (loc, k) -> ret_succ_adding accu (base1 loc k)\n | INat_bytes (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IBytes_int (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IInt_bytes (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IAdd_seconds_to_timestamp (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IAdd_timestamp_to_seconds (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ISub_timestamp_seconds (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IDiff_timestamps (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IAdd_tez (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ISub_tez (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ISub_tez_legacy (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IMul_teznat (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IMul_nattez (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IEdiv_teznat (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IEdiv_tez (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IOr (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IAnd (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IXor (loc, k) -> ret_succ_adding accu (base1 loc k)\n | INot (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IIs_nat (loc, k) -> ret_succ_adding accu (base1 loc k)\n | INeg (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IAbs_int (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IInt_nat (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IAdd_int (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IAdd_nat (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ISub_int (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IMul_int (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IMul_nat (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IEdiv_int (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IEdiv_nat (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ILsl_nat (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ILsr_nat (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IOr_nat (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IAnd_nat (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IAnd_int_nat (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IXor_nat (loc, k) -> ret_succ_adding accu (base1 loc k)\n | INot_int (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IIf {loc; branch_if_true = k1; branch_if_false = k2; k = k3} ->\n ret_succ_adding accu (base3 loc k1 k2 k3)\n | ILoop (loc, k1, k2) -> ret_succ_adding accu (base2 loc k1 k2)\n | ILoop_left (loc, k1, k2) -> ret_succ_adding accu (base2 loc k1 k2)\n | IDip (loc, k1, ty, k2) ->\n ret_succ_adding\n accu\n (base2 loc k1 k2 +! ty_for_logging_size ty +! word_size)\n | IExec (loc, sty, k) ->\n ret_succ_adding\n accu\n (base1 loc k +! stack_ty_for_logging_size sty +! word_size)\n | IApply (loc, ty, k) ->\n ret_succ_adding (accu ++ ty_size ty) (base1 loc k +! word_size)\n | ILambda (loc, lambda, k) ->\n let accu = ret_succ_adding accu (base1 loc k +! word_size) in\n (lambda_size [@ocaml.tailcall]) ~count_lambda_nodes accu lambda\n | IFailwith (loc, ty) ->\n ret_succ_adding (accu ++ ty_size ty) (base0 loc +! word_size)\n | ICompare (loc, cty, k) ->\n ret_succ_adding (accu ++ ty_size cty) (base1 loc k +! word_size)\n | IEq (loc, k) -> ret_succ_adding accu (base1 loc k)\n | INeq (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ILt (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IGt (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ILe (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IGe (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IAddress (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IContract (loc, ty, s, k) ->\n ret_succ_adding\n (accu ++ ty_size ty)\n (base1 loc k +! Entrypoint.in_memory_size s +! (word_size *? 2))\n | IView (loc, s, sty, k) ->\n ret_succ_adding\n (accu ++ view_signature_size s)\n (base1 loc k +! stack_ty_for_logging_size sty +! (word_size *? 2))\n | ITransfer_tokens (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IImplicit_account (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ICreate_contract {loc; storage_type; code; k} ->\n ret_succ_adding\n (accu ++ ty_size storage_type ++ expr_size code)\n (base1 loc k +! (word_size *? 2))\n | ISet_delegate (loc, k) -> ret_succ_adding accu (base1 loc k)\n | INow (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IMin_block_time (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IBalance (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ILevel (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ICheck_signature (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IHash_key (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IPack (loc, ty, k) ->\n ret_succ_adding (accu ++ ty_size ty) (base1 loc k +! word_size)\n | IUnpack (loc, ty, k) ->\n ret_succ_adding (accu ++ ty_size ty) (base1 loc k +! word_size)\n | IBlake2b (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ISha256 (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ISha512 (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ISource (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ISender (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ISelf (loc, ty, s, k) ->\n ret_succ_adding\n (accu ++ ty_size ty)\n (base1 loc k +! (word_size *? 2) +! Entrypoint.in_memory_size s)\n | ISelf_address (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IAmount (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ISapling_empty_state (loc, m, k) ->\n ret_succ_adding\n accu\n (base1 loc k +! word_size +! Sapling.Memo_size.in_memory_size m)\n | ISapling_verify_update (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ISapling_verify_update_deprecated (loc, k) ->\n ret_succ_adding accu (base1 loc k)\n | IDig (loc, n, w, k) ->\n ret_succ_adding\n (accu ++ stack_prefix_preservation_witness_size n w)\n (base1 loc k +! (word_size *? 2))\n | IDug (loc, n, w, k) ->\n ret_succ_adding\n (accu ++ stack_prefix_preservation_witness_size n w)\n (base1 loc k +! (word_size *? 2))\n | IDipn (loc, n, w, k1, k2) ->\n ret_succ_adding\n (accu ++ stack_prefix_preservation_witness_size n w)\n (base2 loc k1 k2 +! (word_size *? 2))\n | IDropn (loc, n, w, k) ->\n ret_succ_adding\n (accu ++ stack_prefix_preservation_witness_size n w)\n (base1 loc k +! (word_size *? 2))\n | IChainId (loc, k) -> ret_succ_adding accu (base1 loc k)\n | INever loc -> ret_succ_adding accu (base0 loc)\n | IVoting_power (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ITotal_voting_power (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IKeccak (loc, k) -> ret_succ_adding accu (base1 loc k)\n | ISha3 (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IAdd_bls12_381_g1 (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IAdd_bls12_381_g2 (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IAdd_bls12_381_fr (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IMul_bls12_381_g1 (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IMul_bls12_381_g2 (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IMul_bls12_381_fr (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IMul_bls12_381_z_fr (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IMul_bls12_381_fr_z (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IInt_bls12_381_fr (loc, k) -> ret_succ_adding accu (base1 loc k)\n | INeg_bls12_381_g1 (loc, k) -> ret_succ_adding accu (base1 loc k)\n | INeg_bls12_381_g2 (loc, k) -> ret_succ_adding accu (base1 loc k)\n | INeg_bls12_381_fr (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IPairing_check_bls12_381 (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IComb (loc, n, w, k) ->\n ret_succ_adding\n accu\n (base1 loc k +! (word_size *? 2) +! comb_gadt_witness_size n w)\n | IUncomb (loc, n, w, k) ->\n ret_succ_adding\n accu\n (base1 loc k +! (word_size *? 2) +! uncomb_gadt_witness_size n w)\n | IComb_get (loc, n, w, k) ->\n ret_succ_adding\n accu\n (base1 loc k +! (word_size *? 2) +! comb_get_gadt_witness_size n w)\n | IComb_set (loc, n, w, k) ->\n ret_succ_adding\n accu\n (base1 loc k +! (word_size *? 2) +! comb_set_gadt_witness_size n w)\n | IDup_n (loc, n, w, k) ->\n ret_succ_adding\n accu\n (base1 loc k +! (word_size *? 2) +! dup_n_gadt_witness_size n w)\n | ITicket (loc, cty, k) ->\n ret_succ_adding\n accu\n (base1 loc k +! ty_for_logging_size cty +! word_size)\n | ITicket_deprecated (loc, cty, k) ->\n ret_succ_adding\n accu\n (base1 loc k +! ty_for_logging_size cty +! word_size)\n | IRead_ticket (loc, ty, k) ->\n ret_succ_adding accu (base1 loc k +! ty_for_logging_size ty +! word_size)\n | ISplit_ticket (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IJoin_tickets (loc, cty, k) ->\n ret_succ_adding (accu ++ ty_size cty) (base1 loc k +! word_size)\n | IOpen_chest (loc, k) -> ret_succ_adding accu (base1 loc k)\n | IEmit {loc; tag; ty; unparsed_ty; k} ->\n ret_succ_adding\n (accu ++ ty_size ty ++ expr_size unparsed_ty)\n (base1 loc k +! Entrypoint.in_memory_size tag +! (word_size *? 3))\n | IHalt loc -> ret_succ_adding accu (base0 loc)\n | ILog _ ->\n (* This instruction is ignored because it is only used for testing.\n Keep this case at the end. *)\n accu\n in\n kinstr_traverse t accu {apply}\n\nlet lambda_size lam = lambda_size ~count_lambda_nodes:true zero lam\n\nlet kinstr_size kinstr = kinstr_size ~count_lambda_nodes:true zero kinstr\n\nlet value_size ty x = value_size ~count_lambda_nodes:true zero ty x\n\nmodule Internal_for_tests = struct\n let ty_size = ty_size\n\n let kinstr_size = kinstr_size\n\n let stack_prefix_preservation_witness_size =\n stack_prefix_preservation_witness_size_internal\nend\n" ;
} ;
{ name = "Script_typed_ir_size_costs" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** [node_size_cost ~nodes] returns the cost of having called\n a function in {!Script_typed_ir_size} that returned [nodes]. *)\nval nodes_cost : nodes:Cache_memory_helpers.Nodes.t -> Gas_limit_repr.cost\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule S = Saturation_repr\n\n(** FIXME insert proper gas constants (the gas constant below was fitted on\n a non-standard machine) *)\nlet nodes_cost ~nodes =\n let open S in\n let nodes = Cache_memory_helpers.Nodes.to_int nodes in\n let coeff = safe_int 45 in\n Gas_limit_repr.atomic_step_cost (mul coeff (S.safe_int nodes))\n" ;
} ;
{ name = "Michelson_v1_gas_costs_generated" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2019-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* Copyright (c) 2022 DaiLambda, Inc. <contact@dailambda.jp> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nmodule S = Saturation_repr\nmodule S_syntax = S.Syntax\n\n(* This file is planned to be automatically generated. *)\n(* If you want to update the following functions, update the gas model instead. *)\n\n(* model N_IAbs_int *)\n(* Allocates [size] bytes. *)\nlet cost_N_IAbs_int size = S.safe_int (20 + (size lsr 1))\n\n(* model N_IAdd_bls12_381_fr *)\n(* when benchmarking, compile bls12-381 without ADX *)\nlet cost_N_IAdd_bls12_381_fr = S.safe_int 30\n\n(* model N_IAdd_bls12_381_g1 *)\n(* when benchmarking, compile bls12-381 without ADX *)\nlet cost_N_IAdd_bls12_381_g1 = S.safe_int 900\n\n(* model N_IAdd_bls12_381_g2 *)\n(* when benchmarking, compile bls12-381 without ADX *)\nlet cost_N_IAdd_bls12_381_g2 = S.safe_int 2_470\n\n(* Allocates [max size1 size2] *)\nlet cost_linear_op_int size1 size2 =\n let open S_syntax in\n let v0 = S.safe_int (Compare.Int.max size1 size2) in\n S.safe_int 35 + (v0 lsr 1)\n\n(* model N_IAdd_int *)\n(* Approximating 0.078154 x term *)\nlet cost_N_IAdd_int = cost_linear_op_int\n\n(* model N_IAdd_nat *)\n(* Approximating 0.077807 x term *)\nlet cost_N_IAdd_nat = cost_linear_op_int\n\n(* model N_IAdd_seconds_to_timestamp *)\n(* Approximating 0.078056 x term *)\nlet cost_N_IAdd_seconds_to_timestamp = cost_linear_op_int\n\n(* model N_IAdd_tez *)\nlet cost_N_IAdd_tez = S.safe_int 20\n\n(* model N_IAdd_timestamp_to_seconds *)\n(* Approximating 0.077771 x term *)\nlet cost_N_IAdd_timestamp_to_seconds = cost_linear_op_int\n\n(* model N_IAddress *)\nlet cost_N_IAddress = S.safe_int 10\n\n(* model N_IAmount *)\nlet cost_N_IAmount = S.safe_int 10\n\n(* model N_IAnd *)\nlet cost_N_IAnd = S.safe_int 10\n\n(* model N_IAnd_int_nat *)\n(* Allocates [min size1 size2] *)\nlet cost_N_IAnd_int_nat size1 size2 =\n let open S_syntax in\n let v0 = S.safe_int (Compare.Int.min size1 size2) in\n S.safe_int 35 + (v0 lsr 1)\n\n(* model N_IAnd_nat *)\n(* Allocates [min size1 size2] *)\nlet cost_N_IAnd_nat size1 size2 =\n let open S_syntax in\n let v0 = S.safe_int (Compare.Int.min size1 size2) in\n S.safe_int 35 + (v0 lsr 1)\n\n(* model N_IAnd_bytes *)\n(* Allocates [min size1 size2] *)\n(* fun size1 -> fun size2 -> (34.8914840649 + (0.398826813115 * (min size1 size2))) *)\nlet cost_N_IAnd_bytes size1 size2 =\n let open S_syntax in\n let v0 = S.safe_int (Compare.Int.min size1 size2) in\n S.safe_int 35 + (v0 lsr 1)\n\n(* model N_IBalance *)\nlet cost_N_IBalance = S.safe_int 10\n\n(* model N_IBlake2b *)\n(* Approximating 1.120804 x term *)\nlet cost_N_IBlake2b size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 430 + v0 + (v0 lsr 3)\n\n(* model N_IBytes_size *)\nlet cost_N_IBytes_size = S.safe_int 10\n\n(* model N_IByte_nat *)\n(* fun size -> (73.6648173983 + (2.97857716538 * size)) *)\nlet cost_N_IBytes_nat size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 75 + (v0 lsl 1) + v0\n\n(* model N_INat_bytes *)\n(* fun size -> (41.2414840649 + (2.47956362254 * size)) *)\nlet cost_N_INat_bytes size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 45 + (v0 lsl 1) + (v0 lsr 1)\n\n(* model N_IBytes_int *)\n(* fun size -> (87.7348173983 + (3.04617929025 * size)) *)\nlet cost_N_IBytes_int size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 90 + (v0 lsl 1) + v0\n\n(* model N_IInt_bytes *)\n(* fun size -> (17.8814840649 + (2.57086493257 * size)) *)\nlet cost_N_IInt_bytes size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 20 + (v0 lsl 1) + (v0 lsr 1)\n\n(* model N_ICar *)\nlet cost_N_ICar = S.safe_int 10\n\n(* model N_ICdr *)\nlet cost_N_ICdr = S.safe_int 10\n\n(* model N_IChainId *)\nlet cost_N_IChainId = S.safe_int 15\n\n(* model N_ICheck_signature_ed25519 *)\n(* Approximating 1.123507 x term *)\nlet cost_N_ICheck_signature_ed25519 size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 65_800 + (v0 + (v0 lsr 3))\n\n(* model N_ICheck_signature_p256 *)\n(* Approximating 1.111539 x term *)\nlet cost_N_ICheck_signature_p256 size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 990_000 + (v0 + (v0 lsr 3))\n\n(* model N_ICheck_signature_secp256k1 *)\n(* Approximating 1.125404 x term *)\nlet cost_N_ICheck_signature_secp256k1 size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 51_600 + (v0 + (v0 lsr 3))\n\n(* model N_ICheck_signature_bls *)\n(* fun size -> (1566529.36815 + (2.94695684559 * size)) *)\nlet cost_N_ICheck_signature_bls size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 1_570_000 + (v0 lsl 1) + v0\n\n(* model N_IComb *)\n(* Approximating 3.531001 x term *)\n(* Note: size >= 2, so the cost is never 0 *)\nlet cost_N_IComb size =\n let open S_syntax in\n let v0 = S.safe_int size in\n (S.safe_int 3 * v0) + (v0 lsr 1) + (v0 lsr 5)\n\n(* model N_IComb_get *)\n(* Approximating 0.573180 x term *)\nlet cost_N_IComb_get size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 20 + (v0 lsr 1) + (v0 lsr 4)\n\n(* model N_IComb_set *)\n(* Approximating 1.287531 x term *)\nlet cost_N_IComb_set size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 20 + (v0 + (v0 lsr 2) + (v0 lsr 5))\n\n(* Model N_ICompare *)\n(* Approximating 0.024413 x term *)\nlet cost_N_ICompare size1 size2 =\n let open S_syntax in\n let v0 = S.safe_int (Compare.Int.min size1 size2) in\n S.safe_int 35 + ((v0 lsr 6) + (v0 lsr 7))\n\n(* model N_IConcat_bytes_pair *)\n(* Allocates [size1 + size2] *)\nlet cost_N_IConcat_bytes_pair size1 size2 =\n let open S_syntax in\n let v0 = S.safe_int size1 + S.safe_int size2 in\n S.safe_int 45 + (v0 lsr 1)\n\n(* model N_IConcat_string_pair *)\n(* Allocates [size1 + size2] *)\nlet cost_N_IConcat_string_pair size1 size2 =\n let open S_syntax in\n let v0 = S.safe_int size1 + S.safe_int size2 in\n S.safe_int 45 + (v0 lsr 1)\n\n(* model N_ICons_list *)\nlet cost_N_ICons_list = S.safe_int 10\n\n(* model N_ICons_none *)\nlet cost_N_ICons_none = S.safe_int 10\n\n(* model N_ICons_pair *)\nlet cost_N_ICons_pair = S.safe_int 10\n\n(* model N_ICons_some *)\nlet cost_N_ICons_some = S.safe_int 10\n\n(* model N_IConst *)\nlet cost_N_IConst = S.safe_int 10\n\n(* model N_IContract *)\nlet cost_N_IContract = S.safe_int 30\n\n(* model N_ICreate_contract *)\nlet cost_N_ICreate_contract = S.safe_int 60\n\n(* model N_IDiff_timestamps *)\n(* Approximating 0.077922 x term *)\nlet cost_N_IDiff_timestamps = cost_linear_op_int\n\n(* model N_IDig *)\n(* Approximating 6.750442 x term *)\nlet cost_N_IDig size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 30 + ((S.safe_int 6 * v0) + (v0 lsr 1) + (v0 lsr 2))\n\n(* model N_IDip *)\nlet cost_N_IDip = S.safe_int 10\n\n(* model N_IDipN *)\n(* Approximating 4.05787663635 x term *)\nlet cost_N_IDipN size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 15 + (S.safe_int 4 * v0)\n\n(* model N_IView *)\nlet cost_N_IView = S.safe_int 1460\n\n(* model N_IDrop *)\nlet cost_N_IDrop = S.safe_int 10\n\n(* model N_IDropN *)\n(* Approximating 2.713108 x term *)\nlet cost_N_IDropN size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 30 + (S.safe_int 2 * v0) + (v0 lsr 1) + (v0 lsr 3)\n\n(* model N_IDug *)\n(* Approximating 6.718396 x term *)\nlet cost_N_IDug size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 35 + ((S.safe_int 6 * v0) + (v0 lsr 1) + (v0 lsr 2))\n\n(* model N_IDup *)\nlet cost_N_IDup = S.safe_int 10\n\n(* model N_IDupN *)\n(* Approximating 1.222263 x term *)\nlet cost_N_IDupN size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 20 + v0 + (v0 lsr 2)\n\nlet cost_div_int size1 size2 =\n (* Allocates at most [size1] bytes *)\n let q = size1 - size2 in\n let open S_syntax in\n let v1 = S.safe_int size1 in\n if Compare.Int.(q < 0) then S.safe_int 105 + (v1 lsr 1)\n else\n let v0 = S.safe_int q * S.safe_int size2 in\n S.safe_int 105 + (v0 lsr 10) + (v0 lsr 11) + (v0 lsr 13) + (v1 lsr 1)\n\n(* model N_IEdiv_int *)\n(* Approximating 0.001591 x term *)\nlet cost_N_IEdiv_int = cost_div_int\n\n(* model N_IEdiv_nat *)\n(* Approximating 0.001605 x term *)\nlet cost_N_IEdiv_nat = cost_div_int\n\n(* model N_IEdiv_tez *)\nlet cost_N_IEdiv_tez = S.safe_int 80\n\n(* model N_IEmpty_big_map *)\nlet cost_N_IEmpty_big_map = S.safe_int 300\n\n(* model N_IEmpty_map *)\nlet cost_N_IEmpty_map = S.safe_int 300\n\n(* model N_IEmpty_set *)\nlet cost_N_IEmpty_set = S.safe_int 300\n\n(* model N_IEq *)\nlet cost_N_IEq = S.safe_int 10\n\n(* model N_IExec *)\nlet cost_N_IExec = S.safe_int 10\n\n(* model N_IFailwith *)\n(* let cost_N_IFailwith = S.safe_int 105 *)\n\n(* model N_IGe *)\nlet cost_N_IGe = S.safe_int 10\n\n(* model N_IGt *)\nlet cost_N_IGt = S.safe_int 10\n\n(* model N_IHalt *)\nlet cost_N_IHalt = S.safe_int 15\n\n(* model N_IHash_key *)\nlet cost_N_IHash_key = S.safe_int 605\n\n(* model N_IIf *)\nlet cost_N_IIf = S.safe_int 10\n\n(* model N_IIf_cons *)\nlet cost_N_IIf_cons = S.safe_int 10\n\n(* model N_IIf_left *)\nlet cost_N_IIf_left = S.safe_int 10\n\n(* model N_IIf_none *)\nlet cost_N_IIf_none = S.safe_int 10\n\n(* model N_IOpt_map *)\nlet cost_N_IOpt_map = S.safe_int 10\n\n(* model N_IImplicit_account *)\nlet cost_N_IImplicit_account = S.safe_int 10\n\n(* model N_IInt_bls12_381_z_fr *)\n(* when benchmarking, compile bls12-381 without ADX *)\nlet cost_N_IInt_bls12_381_z_fr = S.safe_int 115\n\n(* model N_IInt_nat *)\nlet cost_N_IInt_nat = S.safe_int 10\n\n(* model N_IIs_nat *)\nlet cost_N_IIs_nat = S.safe_int 10\n\n(* model N_IKeccak *)\n(* Approximating 8.276352 x term *)\nlet cost_N_IKeccak size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 1350 + ((S.safe_int 8 * v0) + (v0 lsr 2))\n\n(* model N_ILambda *)\nlet cost_N_ILambda = S.safe_int 10\n\n(* model N_ILe *)\nlet cost_N_ILe = S.safe_int 10\n\n(* model N_ILeft *)\nlet cost_N_ILeft = S.safe_int 10\n\n(* model N_ILevel *)\nlet cost_N_ILevel = S.safe_int 10\n\n(* model N_IList_iter *)\nlet cost_N_IList_iter = S.safe_int 20\n\n(* model N_IList_map *)\nlet cost_N_IList_map = S.safe_int 20\n\n(* model N_IList_size *)\nlet cost_N_IList_size = S.safe_int 10\n\n(* model N_ILoop *)\nlet cost_N_ILoop = S.safe_int 10\n\n(* model N_ILoop_left *)\nlet cost_N_ILoop_left = S.safe_int 10\n\n(* model N_ILsl_nat *)\n(* Allocates at most [size + 256] bytes *)\nlet cost_N_ILsl_nat size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 128 + (v0 lsr 1)\n\n(* model N_ILsr_nat *)\n(* Allocates at most [size] bytes*)\nlet cost_N_ILsr_nat size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 45 + (v0 lsr 1)\n\n(* model N_ILsl_bytes *)\n(* Allocates [size + shift / 8] bytes *)\n(* fun size1 -> fun size2 -> ((63.0681507316 + (0.667539714647 * size1)) + (0. * size2)) *)\nlet cost_N_ILsl_bytes size shift =\n let open S_syntax in\n let v1 = S.safe_int size in\n let v0 = S.safe_int shift in\n S.safe_int 65 + (v1 lsr 1) + (v1 lsr 2) + (v0 lsr 4)\n\n(* model N_ILsr_bytes *)\n(* Allocates [max 0 (size - shift / 8)] bytes *)\n(* fun size1 -> fun size2 -> let q = (size1 - (size2 * 0.125)) in (53.9248173983 + (0.658785032381 * (if (0 < q) then q else 0))) *)\nlet cost_N_ILsr_bytes size shift =\n let q = size - (shift lsr 3) in\n let open S.Syntax in\n if Compare.Int.(q < 0) then S.safe_int 55\n else\n let v0 = S.safe_int q in\n S.safe_int 55 + (v0 lsr 1) + (v0 lsr 2)\n\n(* model N_ILt *)\nlet cost_N_ILt = S.safe_int 10\n\n(* model N_IMap_get *)\n(* Approximating 0.048359 x term *)\nlet cost_N_IMap_get size1 size2 =\n let open S_syntax in\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let v0 = size1 * log2 size2 in\n S.safe_int 45 + (v0 lsr 5) + (v0 lsr 6)\n\n(* model N_IMap_get_and_update *)\n(* Approximating 0.145661 x term *)\nlet cost_N_IMap_get_and_update size1 size2 =\n let open S_syntax in\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let v0 = size1 * log2 size2 in\n S.safe_int 75 + (v0 lsr 3) + (v0 lsr 6)\n\n(* model N_IMap_iter *)\n(* Approximating 7.621331 x term *)\nlet cost_N_IMap_iter size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 50 + (S.safe_int 7 * v0) + (v0 lsr 1) + (v0 lsr 3)\n\n(* model N_IMap_map *)\n(* Approximating 8.38965386732 x term *)\nlet cost_N_IMap_map size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 40 + ((S.safe_int 8 * v0) + (v0 lsr 1))\n\n(* model N_IMap_mem *)\n(* Approximating 0.048446 x term *)\nlet cost_N_IMap_mem size1 size2 =\n let open S_syntax in\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let v0 = size1 * log2 size2 in\n S.safe_int 45 + (v0 lsr 5) + (v0 lsr 6)\n\n(* model N_IMap_size *)\nlet cost_N_IMap_size = S.safe_int 10\n\n(* model N_IMap_update *)\n(* Approximating 0.097072 x term *)\nlet cost_N_IMap_update size1 size2 =\n let open S_syntax in\n let size1 = S.safe_int size1 in\n let size2 = S.safe_int size2 in\n let v0 = size1 * log2 size2 in\n S.safe_int 55 + (v0 lsr 4) + (v0 lsr 5)\n\n(* model N_IMul_bls12_381_fr *)\n(* when benchmarking, compile bls12-381 without ADX *)\nlet cost_N_IMul_bls12_381_fr = S.safe_int 45\n\n(* model N_IMul_bls12_381_fr_z *)\n(* Approximating 1.059386 x term *)\n(* when benchmarking, compile bls12-381 without ADX *)\nlet cost_N_IMul_bls12_381_fr_z size1 =\n let open S_syntax in\n let v0 = S.safe_int size1 in\n S.safe_int 265 + v0 + (v0 lsr 4)\n\n(* model N_IMul_bls12_381_g1 *)\n(* when benchmarking, compile bls12-381 without ADX *)\nlet cost_N_IMul_bls12_381_g1 = S.safe_int 103_000\n\n(* model N_IMul_bls12_381_g2 *)\n(* when benchmarking, compile bls12-381 without ADX *)\nlet cost_N_IMul_bls12_381_g2 = S.safe_int 220_000\n\n(* model N_IMul_bls12_381_z_fr *)\n(* Approximating 1.068674 x term *)\n(* when benchmarking, compile bls12-381 without ADX *)\nlet cost_N_IMul_bls12_381_z_fr size1 =\n let open S_syntax in\n let v0 = S.safe_int size1 in\n S.safe_int 265 + v0 + (v0 lsr 4)\n\nlet cost_mul size1 size2 =\n let open S_syntax in\n let a = S.add (S.safe_int size1) (S.safe_int size2) in\n let v0 = a * log2 a in\n S.safe_int 55 + (v0 lsr 1) + (v0 lsr 2) + (v0 lsr 4)\n\n(* model N_IMul_int *)\n(* Approximating 0.857931 x term *)\nlet cost_N_IMul_int = cost_mul\n\n(* model N_IMul_nat *)\n(* Approximating 0.861823 x term *)\nlet cost_N_IMul_nat = cost_mul\n\n(* model N_INeg_bls12_381_fr *)\n(* when benchmarking, compile bls12-381 without ADX *)\nlet cost_N_INeg_bls12_381_fr = S.safe_int 30\n\n(* model N_INeg_bls12_381_g1 *)\n(* when benchmarking, compile bls12-381 without ADX *)\nlet cost_N_INeg_bls12_381_g1 = S.safe_int 50\n\n(* model N_INeg_bls12_381_g2 *)\n(* when benchmarking, compile bls12-381 without ADX *)\nlet cost_N_INeg_bls12_381_g2 = S.safe_int 70\n\n(* model N_INeg *)\n(* Allocates [size] bytes *)\nlet cost_N_INeg size =\n let open S_syntax in\n S.safe_int 25 + (S.safe_int size lsr 1)\n\n(* model N_INeq *)\nlet cost_N_INeq = S.safe_int 10\n\n(* model N_INil *)\nlet cost_N_INil = S.safe_int 10\n\n(* model N_INot *)\nlet cost_N_INot = S.safe_int 10\n\n(* model N_INot_int *)\n(* Allocates [size] bytes *)\nlet cost_N_INot_int size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 25 + (v0 lsr 1)\n\n(* model N_INot_bytes *)\n(* Allocates [size] bytes *)\nlet cost_N_INot_bytes size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 30 + (v0 lsr 1)\n\n(* model N_INow *)\nlet cost_N_INow = S.safe_int 10\n\n(* model N_IMin_block_time *)\nlet cost_N_IMin_block_time = S.safe_int 20\n\n(* model N_IOpen_chest *)\n(* 612000 + chest * 19 + time * 19050 *)\nlet cost_N_IOpen_chest time chest =\n let open S_syntax in\n let v0 = S.safe_int chest in\n let v1 = S.safe_int time in\n S.safe_int 612_000 + (S.safe_int 19 * v0) + (S.safe_int 19050 * v1)\n\n(* model N_IOr *)\nlet cost_N_IOr = S.safe_int 10\n\n(* model N_IOr_nat *)\n(* Approximating 0.075758 x term *)\nlet cost_N_IOr_nat = cost_linear_op_int\n\n(* model N_IOr_bytes *)\n(* Allocates [max size1 size2] bytes *)\n(* fun size1 -> fun size2 -> (32.5381507316 + (0.232425212131 * (max size1 size2))) *)\nlet cost_N_IOr_bytes size1 size2 =\n let open S_syntax in\n let v0 = S.safe_int (Compare.Int.max size1 size2) in\n S.safe_int 35 + (v0 lsr 1)\n\n(* model N_IPairing_check_bls12_381 *)\n(* when benchmarking, compile bls12-381 without ADX *)\nlet cost_N_IPairing_check_bls12_381 size =\n S.add (S.safe_int 450_000) (S.mul (S.safe_int 342_500) (S.safe_int size))\n\n(* model N_IRead_ticket *)\nlet cost_N_IRead_ticket = S.safe_int 10\n\n(* model N_IRight *)\nlet cost_N_IRight = S.safe_int 10\n\n(* model N_ISapling_empty_state *)\nlet cost_N_ISapling_empty_state = S.safe_int 300\n\n(* model N_ISelf_address *)\nlet cost_N_ISelf_address = S.safe_int 10\n\n(* model N_ISelf *)\nlet cost_N_ISelf = S.safe_int 10\n\n(* model N_ISender *)\nlet cost_N_ISender = S.safe_int 10\n\n(* model N_ISet_delegate *)\nlet cost_N_ISet_delegate = S.safe_int 60\n\n(* model N_ISet_iter *)\n(* Approximating 7.633555 x term *)\nlet cost_N_ISet_iter size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 50 + (S.safe_int 7 * v0) + (v0 lsr 1) + (v0 lsr 3)\n\n(* model N_ISet_size *)\nlet cost_N_ISet_size = S.safe_int 10\n\n(* model N_ISha256 *)\n(* Approximating 4.763264 x term *)\nlet cost_N_ISha256 size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 600 + ((S.safe_int 4 * v0) + (v0 lsr 1) + (v0 lsr 2))\n\n(* model N_ISha3 *)\n(* Approximating 8.362339 x term *)\nlet cost_N_ISha3 = cost_N_IKeccak\n\n(* model N_ISha512 *)\n(* Approximating 3.074641 x term *)\nlet cost_N_ISha512 size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 680 + (S.safe_int 3 * v0)\n\n(* model N_ISlice_bytes *)\n(* Allocates [size] bytes *)\nlet cost_N_ISlice_bytes size =\n let open S_syntax in\n S.safe_int 25 + (S.safe_int size lsr 1)\n\n(* model N_ISlice_string *)\n(* Allocates [size] bytes *)\nlet cost_N_ISlice_string size =\n let open S_syntax in\n S.safe_int 25 + (S.safe_int size lsr 1)\n\n(* model N_ISource *)\nlet cost_N_ISource = S.safe_int 10\n\n(* model N_ISplit_ticket *)\n(* Allocates [max size1 size2] *)\nlet cost_N_ISplit_ticket size1 size2 =\n let open S_syntax in\n let v1 = S.safe_int (Compare.Int.max size1 size2) in\n S.safe_int 40 + (v1 lsr 1)\n\n(* model N_IString_size *)\nlet cost_N_IString_size = S.safe_int 15\n\n(* model N_ISub_int *)\n(* Approximating 0.077849 x term *)\nlet cost_N_ISub_int = cost_linear_op_int\n\n(* model N_ISub_tez *)\nlet cost_N_ISub_tez = S.safe_int 15\n\n(* model N_ISub_tez_legacy *)\nlet cost_N_ISub_tez_legacy = S.safe_int 20\n\n(* model N_ISub_timestamp_seconds *)\n(* Approximating 0.077794 x term *)\nlet cost_N_ISub_timestamp_seconds = cost_linear_op_int\n\n(* model N_ISwap *)\nlet cost_N_ISwap = S.safe_int 10\n\n(* model N_ITicket *)\nlet cost_N_ITicket = S.safe_int 10\n\n(* model N_ITotal_voting_power *)\nlet cost_N_ITotal_voting_power = S.safe_int 450\n\n(* model N_ITransfer_tokens *)\nlet cost_N_ITransfer_tokens = S.safe_int 60\n\n(* model N_IUncomb *)\n(* Approximating 3.944710 x term *)\nlet cost_N_IUncomb size =\n let open S_syntax in\n let v0 = S.safe_int size in\n S.safe_int 25 + (S.safe_int 4 * v0)\n\n(* model N_IUnpair *)\nlet cost_N_IUnpair = S.safe_int 10\n\n(* model N_IVoting_power *)\nlet cost_N_IVoting_power = S.safe_int 640\n\n(* model N_IXor *)\nlet cost_N_IXor = S.safe_int 15\n\n(* model N_IXor_nat *)\n(* Approximating 0.075601 x term *)\nlet cost_N_IXor_nat = cost_linear_op_int\n\n(* model N_IXor_bytes *)\n(* Allocates [max size1 size2] bytes *)\n(* fun size1 -> fun size2 -> (38.5110342369 + (0.397946895815 * (max size1 size2))) *)\nlet cost_N_IXor_bytes size1 size2 =\n let open S_syntax in\n let v0 = S.safe_int (Compare.Int.max size1 size2) in\n S.safe_int 40 + (v0 lsr 1)\n\n(* model N_KCons *)\nlet cost_N_KCons = S.safe_int 10\n\n(* model N_KList_exit_body *)\nlet cost_N_KList_exit_body = S.safe_int 10\n\n(* model N_KLoop_in *)\nlet cost_N_KLoop_in = S.safe_int 10\n\n(* model N_KLoop_in_left *)\nlet cost_N_KLoop_in_left = S.safe_int 10\n\n(* model N_KNil *)\nlet cost_N_KNil = S.safe_int 15\n\n(* model N_KReturn *)\nlet cost_N_KReturn = S.safe_int 10\n\n(* model N_KView_exit *)\nlet cost_N_KView_exit = S.safe_int 20\n\n(* model N_KMap_head *)\nlet cost_N_KMap_head = S.safe_int 20\n\n(* model N_KUndip *)\nlet cost_N_KUndip = S.safe_int 10\n\n(* model DECODING_BLS_FR *)\n(* when benchmarking, compile bls12-381 without ADX, see\n https://gitlab.com/dannywillems/ocaml-bls12-381/-/blob/71d0b4d467fbfaa6452d702fcc408d7a70916a80/README.md#install\n*)\nlet cost_DECODING_BLS_FR = S.safe_int 120\n\n(* model DECODING_BLS_G1 *)\n(* when benchmarking, compile bls12-381 without ADX *)\nlet cost_DECODING_BLS_G1 = S.safe_int 54_600\n\n(* model DECODING_BLS_G2 *)\n(* when benchmarking, compile bls12-381 without ADX *)\nlet cost_DECODING_BLS_G2 = S.safe_int 69_000\n\n(* model B58CHECK_DECODING_CHAIN_ID *)\nlet cost_B58CHECK_DECODING_CHAIN_ID = S.safe_int 1_600\n\n(* model B58CHECK_DECODING_PUBLIC_KEY_HASH_ed25519 *)\nlet cost_B58CHECK_DECODING_PUBLIC_KEY_HASH_ed25519 = S.safe_int 3_300\n\n(* model B58CHECK_DECODING_PUBLIC_KEY_HASH_p256 *)\nlet cost_B58CHECK_DECODING_PUBLIC_KEY_HASH_p256 = S.safe_int 3_300\n\n(* model B58CHECK_DECODING_PUBLIC_KEY_HASH_secp256k1 *)\nlet cost_B58CHECK_DECODING_PUBLIC_KEY_HASH_secp256k1 = S.safe_int 3_300\n\n(* model B58CHECK_DECODING_PUBLIC_KEY_HASH_bls *)\nlet cost_B58CHECK_DECODING_PUBLIC_KEY_HASH_bls = S.safe_int 3_600\n\n(* model B58CHECK_DECODING_PUBLIC_KEY_ed25519 *)\nlet cost_B58CHECK_DECODING_PUBLIC_KEY_ed25519 = S.safe_int 4_200\n\n(* model B58CHECK_DECODING_PUBLIC_KEY_p256 *)\nlet cost_B58CHECK_DECODING_PUBLIC_KEY_p256 = S.safe_int 325_000\n\n(* model B58CHECK_DECODING_PUBLIC_KEY_secp256k1 *)\nlet cost_B58CHECK_DECODING_PUBLIC_KEY_secp256k1 = S.safe_int 9_000\n\n(* model B58CHECK_DECODING_PUBLIC_KEY_bls *)\nlet cost_B58CHECK_DECODING_PUBLIC_KEY_bls = S.safe_int 79_000\n\n(* model B58CHECK_DECODING_SIGNATURE_ed25519 *)\nlet cost_B58CHECK_DECODING_SIGNATURE_ed25519 = S.safe_int 6_400\n\n(* model B58CHECK_DECODING_SIGNATURE_p256 *)\nlet cost_B58CHECK_DECODING_SIGNATURE_p256 = S.safe_int 6_400\n\n(* model B58CHECK_DECODING_SIGNATURE_secp256k1 *)\nlet cost_B58CHECK_DECODING_SIGNATURE_secp256k1 = S.safe_int 6_400\n\n(* model B58CHECK_DECODING_SIGNATURE_bls *)\nlet cost_B58CHECK_DECODING_SIGNATURE_bls = S.safe_int 6_400\n\n(* model ENCODING_BLS_FR *)\nlet cost_ENCODING_BLS_FR = S.safe_int 80\n\n(* model ENCODING_BLS_G1 *)\nlet cost_ENCODING_BLS_G1 = S.safe_int 3200\n\n(* model ENCODING_BLS_G2 *)\nlet cost_ENCODING_BLS_G2 = S.safe_int 3900\n\n(* model B58CHECK_ENCODING_CHAIN_ID *)\nlet cost_B58CHECK_ENCODING_CHAIN_ID = S.safe_int 1_800\n\n(* model B58CHECK_ENCODING_PUBLIC_KEY_HASH_ed25519 *)\nlet cost_B58CHECK_ENCODING_PUBLIC_KEY_HASH_ed25519 = S.safe_int 3_200\n\n(* model B58CHECK_ENCODING_PUBLIC_KEY_HASH_p256 *)\nlet cost_B58CHECK_ENCODING_PUBLIC_KEY_HASH_p256 = S.safe_int 3_200\n\n(* model B58CHECK_ENCODING_PUBLIC_KEY_HASH_secp256k1 *)\nlet cost_B58CHECK_ENCODING_PUBLIC_KEY_HASH_secp256k1 = S.safe_int 3_200\n\n(* model B58CHECK_ENCODING_PUBLIC_KEY_HASH_bls *)\nlet cost_B58CHECK_ENCODING_PUBLIC_KEY_HASH_bls = S.safe_int 3_200\n\n(* model B58CHECK_ENCODING_PUBLIC_KEY_ed25519 *)\nlet cost_B58CHECK_ENCODING_PUBLIC_KEY_ed25519 = S.safe_int 4_500\n\n(* model B58CHECK_ENCODING_PUBLIC_KEY_p256 *)\nlet cost_B58CHECK_ENCODING_PUBLIC_KEY_p256 = S.safe_int 4_550\n\n(* model B58CHECK_ENCODING_PUBLIC_KEY_secp256k1 *)\nlet cost_B58CHECK_ENCODING_PUBLIC_KEY_secp256k1 = S.safe_int 4_950\n\n(* model B58CHECK_ENCODING_PUBLIC_KEY_bls *)\nlet cost_B58CHECK_ENCODING_PUBLIC_KEY_bls = S.safe_int 5_900\n\n(* model B58CHECK_ENCODING_SIGNATURE_ed25519 *)\nlet cost_B58CHECK_ENCODING_SIGNATURE_ed25519 = S.safe_int 8_300\n\n(* model B58CHECK_ENCODING_SIGNATURE_p256 *)\nlet cost_B58CHECK_ENCODING_SIGNATURE_p256 = S.safe_int 8_300\n\n(* model B58CHECK_ENCODING_SIGNATURE_secp256k1 *)\nlet cost_B58CHECK_ENCODING_SIGNATURE_secp256k1 = S.safe_int 8_300\n\n(* model B58CHECK_ENCODING_SIGNATURE_bls *)\nlet cost_B58CHECK_ENCODING_SIGNATURE_bls = S.safe_int 8_300\n\n(* model DECODING_CHAIN_ID *)\nlet cost_DECODING_CHAIN_ID = S.safe_int 50\n\n(* model DECODING_PUBLIC_KEY_HASH_ed25519 *)\nlet cost_DECODING_PUBLIC_KEY_HASH_ed25519 = S.safe_int 60\n\n(* model DECODING_PUBLIC_KEY_HASH_p256 *)\nlet cost_DECODING_PUBLIC_KEY_HASH_p256 = S.safe_int 60\n\n(* model DECODING_PUBLIC_KEY_HASH_secp256k1 *)\nlet cost_DECODING_PUBLIC_KEY_HASH_secp256k1 = S.safe_int 60\n\n(* model DECODING_PUBLIC_KEY_HASH_bls *)\nlet cost_DECODING_PUBLIC_KEY_HASH_bls = S.safe_int 60\n\n(* model DECODING_PUBLIC_KEY_ed25519 *)\nlet cost_DECODING_PUBLIC_KEY_ed25519 = S.safe_int 60\n\n(* model DECODING_PUBLIC_KEY_p256 *)\nlet cost_DECODING_PUBLIC_KEY_p256 = S.safe_int 18_800\n\n(* model DECODING_PUBLIC_KEY_secp256k1 *)\nlet cost_DECODING_PUBLIC_KEY_secp256k1 = S.safe_int 4_900\n\n(* model DECODING_PUBLIC_KEY_bls *)\nlet cost_DECODING_PUBLIC_KEY_bls = S.safe_int 74_000\n\n(* model DECODING_SIGNATURE_ed25519 *)\nlet cost_DECODING_SIGNATURE_ed25519 = S.safe_int 35\n\n(* model DECODING_SIGNATURE_p256 *)\nlet cost_DECODING_SIGNATURE_p256 = S.safe_int 35\n\n(* model DECODING_SIGNATURE_secp256k1 *)\nlet cost_DECODING_SIGNATURE_secp256k1 = S.safe_int 35\n\n(* model DECODING_SIGNATURE_bls *)\nlet cost_DECODING_SIGNATURE_bls = S.safe_int 40\n\n(* model DECODING_Chest_key *)\nlet cost_DECODING_Chest_key = S.safe_int 5900\n\n(* model DECODING_Chest *)\n(* Approximating 0.039349 x term *)\nlet cost_DECODING_Chest bytes =\n let open S_syntax in\n let v0 = S.safe_int bytes in\n S.safe_int 7400 + (v0 lsr 5) + (v0 lsr 7)\n\n(* model ENCODING_CHAIN_ID *)\nlet cost_ENCODING_CHAIN_ID = S.safe_int 50\n\n(* model ENCODING_PUBLIC_KEY_HASH_ed25519 *)\nlet cost_ENCODING_PUBLIC_KEY_HASH_ed25519 = S.safe_int 70\n\n(* model ENCODING_PUBLIC_KEY_HASH_p256 *)\nlet cost_ENCODING_PUBLIC_KEY_HASH_p256 = S.safe_int 70\n\n(* model ENCODING_PUBLIC_KEY_HASH_secp256k1 *)\nlet cost_ENCODING_PUBLIC_KEY_HASH_secp256k1 = S.safe_int 70\n\n(* model ENCODING_PUBLIC_KEY_HASH_bls *)\nlet cost_ENCODING_PUBLIC_KEY_HASH_bls = S.safe_int 80\n\n(* model ENCODING_PUBLIC_KEY_ed25519 *)\nlet cost_ENCODING_PUBLIC_KEY_ed25519 = S.safe_int 80\n\n(* model ENCODING_PUBLIC_KEY_p256 *)\nlet cost_ENCODING_PUBLIC_KEY_p256 = S.safe_int 90\n\n(* model ENCODING_PUBLIC_KEY_secp256k1 *)\nlet cost_ENCODING_PUBLIC_KEY_secp256k1 = S.safe_int 455\n\n(* model ENCODING_PUBLIC_KEY_bls *)\nlet cost_ENCODING_PUBLIC_KEY_bls = S.safe_int 90\n\n(* model ENCODING_SIGNATURE_ed25519 *)\nlet cost_ENCODING_SIGNATURE_ed25519 = S.safe_int 45\n\n(* model ENCODING_SIGNATURE_p256 *)\nlet cost_ENCODING_SIGNATURE_p256 = S.safe_int 45\n\n(* model ENCODING_SIGNATURE_secp256k1 *)\nlet cost_ENCODING_SIGNATURE_secp256k1 = S.safe_int 45\n\n(* model ENCODING_SIGNATURE_bls *)\nlet cost_ENCODING_SIGNATURE_bls = S.safe_int 55\n\n(* model ENCODING_Chest_key *)\nlet cost_ENCODING_Chest_key = S.safe_int 10_000\n\n(* model ENCODING_Chest *)\n(* Approximating 0.120086 x term *)\nlet cost_ENCODING_Chest plaintext_size =\n let open S_syntax in\n let v0 = S.safe_int plaintext_size in\n S.safe_int 12_200 + (v0 lsr 3)\n\n(* model TIMESTAMP_READABLE_DECODING *)\n(* Approximating 0.045400 x term *)\nlet cost_TIMESTAMP_READABLE_DECODING bytes =\n let open S_syntax in\n let b = S.safe_int bytes in\n let v0 = S.mul (S.sqrt b) b in\n S.safe_int 105 + ((v0 lsr 5) + (v0 lsr 6))\n\n(* model TIMESTAMP_READABLE_ENCODING *)\nlet cost_TIMESTAMP_READABLE_ENCODING = S.safe_int 820\n\n(* model CHECK_PRINTABLE *)\nlet cost_CHECK_PRINTABLE size =\n let open S_syntax in\n S.safe_int 14 + (S.safe_int 10 * S.safe_int size)\n\n(* model IEmit *)\nlet cost_N_IEmit = S.safe_int 30\n" ;
} ;
{ name = "Michelson_v1_gas_costs" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2019-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* Copyright (c) 2022 DaiLambda, Inc. <contact@dailambda.jp> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ninclude Michelson_v1_gas_costs_generated\nmodule S = Saturation_repr\n\n(* This file contains functions saved from\n the original michelson_v1_gas_costs.ml.\n These functions couldn't be generated by the snoop tool. *)\n\n(* N_IMul_nattez / N_IMul_teznat\n These functions are benchmarked with the affine model.\n However, empirically, the coefficient is ignorably small. *)\n\n(* model N_IMul_nattez *)\nlet cost_N_IMul_nattez = S.safe_int 50\n\n(* model N_IMul_teznat *)\nlet cost_N_IMul_teznat = S.safe_int 50\n\n(* N_IEdiv_teznat\n This function is modeled with `division_cost` model,\n which takes two arguments, divisor and dividend. *)\n\n(* model N_IEdiv_teznat *)\nlet cost_N_IEdiv_teznat = S.safe_int 70\n\n(* N_ISapling_verify_update\n This function depends on another cost function cost_N_IBlake2b.\n Such code can't be generated by the current Snoop. *)\n\n(* model N_ISapling_verify_update *)\n(* Inferred cost (without cost_N_IBlake2b) is:\n fun size1 -> fun size2 -> ((432200.469784 + (5738377.05148 * size1)) + (4634026.28586 * size2)) *)\nlet cost_N_ISapling_verify_update size1 size2 bound_data =\n let open S.Syntax in\n let v1 = S.safe_int size1 in\n let v2 = S.safe_int size2 in\n cost_N_IBlake2b bound_data + S.safe_int 432_500\n + (S.safe_int 5_740_000 * v1)\n + (S.safe_int 4_635_000 * v2)\n\n(* N_IApply\n The current generated model receives int as a flag,\n but it should receive bool. *)\n\n(* model N_IApply *)\nlet cost_N_IApply rec_flag = if rec_flag then S.safe_int 220 else S.safe_int 140\n\n(* N_KIter / N_KMap_enter_body\n The empty_branch_model are used as the models.\n However, the defined cost functions receive nothing. *)\n\n(* model N_KIter *)\nlet cost_N_KIter = S.safe_int 10\n\n(* model N_KMap_enter_body *)\nlet cost_N_KMap_enter_body = S.safe_int 80\n\n(* N_KList_enter_body\n The generated model receives the length of `xs` as the first argument\n and branches on whether it is 0 or not.\n However, calculating the length makes the performance worse.\n The model should be changed to receive `xs_is_nil` as the first argument. *)\n\n(* model N_KList_enter_body *)\n(* Approximating 1.797068 x term *)\nlet cost_N_KList_enter_body xs size_ys =\n match xs with\n | [] ->\n let open S.Syntax in\n let v0 = S.safe_int size_ys in\n S.safe_int 30 + (v0 + (v0 lsr 1) + (v0 lsr 2) + (v0 lsr 4))\n | _ :: _ -> S.safe_int 30\n\n(* TY_EQ / PARSE_TYPE / UNPARSE_TYPE / TYPECHECKING_CODE / UNPARSING_CODE\n TYPECHECKING_DATA / UNPARSING_DATA / FIND_ENTRYPOINT\n Following functions are commented to indicate that they were manually modified. *)\n\n(* model TY_EQ\n This is the estimated cost of one iteration of ty_eq, extracted\n and copied manually from the parameter fit for the TY_EQ benchmark\n (the model is parametric on the size of the type, which we don't have\n access to in O(1)). *)\nlet cost_TY_EQ = S.safe_int 60\n\n(* model PARSE_TYPE\n This is the cost of one iteration of parse_ty, extracted by hand from the\n parameter fit for the PARSE_TYPE benchmark. *)\nlet cost_PARSE_TYPE = S.safe_int 60\n\n(* model UNPARSE_TYPE\n This is the cost of one iteration of unparse_ty, extracted by hand from the\n parameter fit for the UNPARSE_TYPE benchmark. *)\nlet cost_UNPARSE_TYPE type_size = S.mul (S.safe_int 20) type_size\n\n(* model TYPECHECKING_CODE\n This is the cost of one iteration of parse_instr, extracted by hand from the\n parameter fit for the TYPECHECKING_CODE benchmark. *)\nlet cost_TYPECHECKING_CODE = S.safe_int 220\n\n(* model UNPARSING_CODE\n This is the cost of one iteration of unparse_instr, extracted by hand from the\n parameter fit for the UNPARSING_CODE benchmark. *)\nlet cost_UNPARSING_CODE = S.safe_int 115\n\n(* model TYPECHECKING_DATA\n This is the cost of one iteration of parse_data, extracted by hand from the\n parameter fit for the TYPECHECKING_DATA benchmark. *)\nlet cost_TYPECHECKING_DATA = S.safe_int 100\n\n(* model UNPARSING_DATA\n This is the cost of one iteration of unparse_data, extracted by hand from the\n parameter fit for the UNPARSING_DATA benchmark. *)\nlet cost_UNPARSING_DATA = S.safe_int 65\n\n(* TODO: https://gitlab.com/tezos/tezos/-/issues/2264\n Benchmark.\n Currently approximated by 2 comparisons of the longest entrypoint. *)\nlet cost_FIND_ENTRYPOINT = cost_N_ICompare 31 31\n\n(* SAPLING_TRANSACTION_ENCODING / SAPLING_DIFF_ENCODING\n These functions are missing model definitions. *)\n\n(* model SAPLING_TRANSACTION_ENCODING *)\nlet cost_SAPLING_TRANSACTION_ENCODING ~inputs ~outputs ~bound_data =\n S.safe_int (1500 + (inputs * 160) + (outputs * 320) + (bound_data lsr 3))\n\n(* model SAPLING_DIFF_ENCODING *)\nlet cost_SAPLING_DIFF_ENCODING ~nfs ~cms = S.safe_int ((nfs * 22) + (cms * 215))\n" ;
} ;
{ name = "Michelson_v1_gas" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2019-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 DaiLambda, Inc. <contact@dailambda,jp> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module provides the gas costs for typechecking Michelson scripts,\n parsing and unparsing Michelson values, and interpreting Michelson\n instructions.\n*)\n\nopen Alpha_context\n\nmodule Cost_of : sig\n val manager_operation : Gas.cost\n\n module Interpreter : sig\n val drop : Gas.cost\n\n val dup : Gas.cost\n\n val swap : Gas.cost\n\n val cons_some : Gas.cost\n\n val cons_none : Gas.cost\n\n val if_none : Gas.cost\n\n val opt_map : Gas.cost\n\n val cons_pair : Gas.cost\n\n val unpair : Gas.cost\n\n val car : Gas.cost\n\n val cdr : Gas.cost\n\n val cons_left : Gas.cost\n\n val cons_right : Gas.cost\n\n val if_left : Gas.cost\n\n val cons_list : Gas.cost\n\n val nil : Gas.cost\n\n val if_cons : Gas.cost\n\n (* The argument of this function is ignored when calculating gas cost. *)\n val list_map : 'a Script_list.t -> Gas.cost\n\n val list_size : Gas.cost\n\n (* The argument of this function is ignored when calculating gas cost. *)\n val list_iter : 'a Script_list.t -> Gas.cost\n\n val empty_set : Gas.cost\n\n val set_iter : 'a Script_typed_ir.set -> Gas.cost\n\n val set_mem : 'a -> 'a Script_typed_ir.set -> Gas.cost\n\n val set_update : 'a -> 'a Script_typed_ir.set -> Gas.cost\n\n val set_size : Gas.cost\n\n val empty_map : Gas.cost\n\n val map_map : ('k, 'v) Script_typed_ir.map -> Gas.cost\n\n val map_iter : ('k, 'v) Script_typed_ir.map -> Gas.cost\n\n val map_mem : 'k -> ('k, 'v) Script_typed_ir.map -> Gas.cost\n\n val map_get : 'k -> ('k, 'v) Script_typed_ir.map -> Gas.cost\n\n val map_update : 'k -> ('k, 'v) Script_typed_ir.map -> Gas.cost\n\n val map_get_and_update : 'k -> ('k, 'v) Script_typed_ir.map -> Gas.cost\n\n val big_map_mem : (_, _) Script_typed_ir.big_map_overlay -> Gas.cost\n\n val big_map_get : (_, _) Script_typed_ir.big_map_overlay -> Gas.cost\n\n val big_map_update : (_, _) Script_typed_ir.big_map_overlay -> Gas.cost\n\n val big_map_get_and_update :\n (_, _) Script_typed_ir.big_map_overlay -> Gas.cost\n\n val map_size : Gas.cost\n\n val add_seconds_timestamp :\n 'a Script_int.num -> Script_timestamp.t -> Gas.cost\n\n val add_timestamp_seconds :\n Script_timestamp.t -> 'a Script_int.num -> Gas.cost\n\n val sub_timestamp_seconds :\n Script_timestamp.t -> 'a Script_int.num -> Gas.cost\n\n val diff_timestamps : Script_timestamp.t -> Script_timestamp.t -> Gas.cost\n\n val concat_string_pair : Script_string.t -> Script_string.t -> Gas.cost\n\n val slice_string : Script_string.t -> Gas.cost\n\n val string_size : Gas.cost\n\n val concat_bytes_pair : bytes -> bytes -> Gas.cost\n\n val slice_bytes : bytes -> Gas.cost\n\n val bytes_size : Gas.cost\n\n val bytes_nat : Script_int.n Script_int.num -> Gas.cost\n\n val nat_bytes : bytes -> Gas.cost\n\n val bytes_int : Script_int.z Script_int.num -> Gas.cost\n\n val int_bytes : bytes -> Gas.cost\n\n val add_tez : Gas.cost\n\n val sub_tez : Gas.cost\n\n val sub_tez_legacy : Gas.cost\n\n val mul_teznat : Gas.cost\n\n val mul_nattez : Gas.cost\n\n val bool_or : Gas.cost\n\n val bool_and : Gas.cost\n\n val bool_xor : Gas.cost\n\n val bool_not : Gas.cost\n\n val is_nat : Gas.cost\n\n val abs_int : Script_int.z Script_int.num -> Gas.cost\n\n val int_nat : Gas.cost\n\n val neg : 'a Script_int.num -> Gas.cost\n\n val add_int : 'a Script_int.num -> 'b Script_int.num -> Gas.cost\n\n val add_nat :\n Script_int.n Script_int.num -> Script_int.n Script_int.num -> Gas.cost\n\n val sub_int : 'a Script_int.num -> 'b Script_int.num -> Gas.cost\n\n val mul_int : 'a Script_int.num -> 'b Script_int.num -> Gas.cost\n\n val mul_nat : Script_int.n Script_int.num -> 'a Script_int.num -> Gas.cost\n\n val ediv_teznat : 'a -> 'b Script_int.num -> Gas.cost\n\n val ediv_tez : Gas.cost\n\n val ediv_int : 'a Script_int.num -> 'b Script_int.num -> Gas.cost\n\n val ediv_nat : Script_int.n Script_int.num -> 'a Script_int.num -> Gas.cost\n\n val eq : Gas.cost\n\n val lsl_nat : 'a Script_int.num -> Gas.cost\n\n val lsr_nat : 'a Script_int.num -> Gas.cost\n\n val lsl_bytes : bytes -> Script_int.n Script_int.num -> Gas.cost\n\n val lsr_bytes : bytes -> Script_int.n Script_int.num -> Gas.cost\n\n val or_nat : 'a Script_int.num -> 'b Script_int.num -> Gas.cost\n\n val or_bytes : bytes -> bytes -> Gas.cost\n\n val and_nat : 'a Script_int.num -> 'b Script_int.num -> Gas.cost\n\n val and_int_nat :\n Script_int.z Script_int.num -> Script_int.n Script_int.num -> Gas.cost\n\n val and_bytes : bytes -> bytes -> Gas.cost\n\n val xor_nat : 'a Script_int.num -> 'b Script_int.num -> Gas.cost\n\n val xor_bytes : bytes -> bytes -> Gas.cost\n\n val not_int : 'a Script_int.num -> Gas.cost\n\n val not_bytes : bytes -> Gas.cost\n\n val if_ : Gas.cost\n\n val loop : Gas.cost\n\n val loop_left : Gas.cost\n\n val dip : Gas.cost\n\n val check_signature : Signature.public_key -> bytes -> Gas.cost\n\n val blake2b : bytes -> Gas.cost\n\n val sha256 : bytes -> Gas.cost\n\n val sha512 : bytes -> Gas.cost\n\n val dign : int -> Gas.cost\n\n val dugn : int -> Gas.cost\n\n val dipn : int -> Gas.cost\n\n val dropn : int -> Gas.cost\n\n val voting_power : Gas.cost\n\n val total_voting_power : Gas.cost\n\n val keccak : bytes -> Gas.cost\n\n val sha3 : bytes -> Gas.cost\n\n val add_bls12_381_g1 : Gas.cost\n\n val add_bls12_381_g2 : Gas.cost\n\n val add_bls12_381_fr : Gas.cost\n\n val mul_bls12_381_g1 : Gas.cost\n\n val mul_bls12_381_g2 : Gas.cost\n\n val mul_bls12_381_fr : Gas.cost\n\n val mul_bls12_381_fr_z : 'a Script_int.num -> Gas.cost\n\n val mul_bls12_381_z_fr : 'a Script_int.num -> Gas.cost\n\n val int_bls12_381_fr : Gas.cost\n\n val neg_bls12_381_g1 : Gas.cost\n\n val neg_bls12_381_g2 : Gas.cost\n\n val neg_bls12_381_fr : Gas.cost\n\n val neq : Gas.cost\n\n val pairing_check_bls12_381 : 'a Script_list.t -> Gas.cost\n\n val comb : int -> Gas.cost\n\n val uncomb : int -> Gas.cost\n\n val comb_get : int -> Gas.cost\n\n val comb_set : int -> Gas.cost\n\n val dupn : int -> Gas.cost\n\n val compare : 'a Script_typed_ir.comparable_ty -> 'a -> 'a -> Gas.cost\n\n val concat_string_precheck : 'a Script_list.t -> Gas.cost\n\n val concat_string :\n Saturation_repr.may_saturate Saturation_repr.t -> Gas.cost\n\n val concat_bytes :\n Saturation_repr.may_saturate Saturation_repr.t -> Gas.cost\n\n val halt : Gas.cost\n\n val const : Gas.cost\n\n val empty_big_map : Gas.cost\n\n val lt : Gas.cost\n\n val le : Gas.cost\n\n val gt : Gas.cost\n\n val ge : Gas.cost\n\n val exec : Gas.cost\n\n val apply : rec_flag:bool -> Gas.cost\n\n val lambda : Gas.cost\n\n val address : Gas.cost\n\n val contract : Gas.cost\n\n val view : Gas.cost\n\n val view_get : Script_string.t -> Script_typed_ir.view_map -> Gas.cost\n\n val view_update : Script_string.t -> Script_typed_ir.view_map -> Gas.cost\n\n val transfer_tokens : Gas.cost\n\n val implicit_account : Gas.cost\n\n val create_contract : Gas.cost\n\n val set_delegate : Gas.cost\n\n val balance : Gas.cost\n\n val level : Gas.cost\n\n val now : Gas.cost\n\n val min_block_time : Gas.cost\n\n val hash_key : Signature.Public_key.t -> Gas.cost\n\n val source : Gas.cost\n\n val sender : Gas.cost\n\n val self : Gas.cost\n\n val self_address : Gas.cost\n\n val amount : Gas.cost\n\n val chain_id : Gas.cost\n\n val unpack : bytes -> Gas.cost\n\n val unpack_failed : string -> Gas.cost\n\n val sapling_empty_state : Gas.cost\n\n val sapling_verify_update :\n inputs:int -> outputs:int -> bound_data:int -> Gas.cost\n\n val sapling_verify_update_deprecated : inputs:int -> outputs:int -> Gas.cost\n\n val ticket : Gas.cost\n\n val read_ticket : Gas.cost\n\n val split_ticket : 'a Script_int.num -> 'a Script_int.num -> Gas.cost\n\n val join_tickets :\n 'a Script_typed_ir.comparable_ty ->\n 'a Script_typed_ir.ticket ->\n 'a Script_typed_ir.ticket ->\n Gas.cost\n\n val open_chest :\n chest:Script_typed_ir.Script_timelock.chest -> time:Z.t -> Gas.cost\n\n (** cost to generate one event emission internal operation *)\n val emit : Gas.cost\n\n module Control : sig\n val nil : Gas.cost\n\n val cons : Gas.cost\n\n val return : Gas.cost\n\n val view_exit : Gas.cost\n\n val map_head : Gas.cost\n\n val undip : Gas.cost\n\n val loop_in : Gas.cost\n\n val loop_in_left : Gas.cost\n\n val iter : Gas.cost\n\n val list_enter_body : 'a list -> int -> Gas.cost\n\n val list_exit_body : Gas.cost\n\n val map_enter_body : Gas.cost\n\n val map_exit_body : 'k -> ('k, 'v) Script_typed_ir.map -> Gas.cost\n end\n end\n\n module Typechecking : sig\n val public_key_optimized : Gas.cost\n\n val public_key_readable : Gas.cost\n\n val key_hash_optimized : Gas.cost\n\n val key_hash_readable : Gas.cost\n\n val signature_optimized : Gas.cost\n\n val signature_readable : Gas.cost\n\n val chain_id_optimized : Gas.cost\n\n val chain_id_readable : Gas.cost\n\n val address_optimized : Gas.cost\n\n val contract_optimized : Gas.cost\n\n val contract_readable : Gas.cost\n\n val bls12_381_g1 : Gas.cost\n\n val bls12_381_g2 : Gas.cost\n\n val bls12_381_fr : Gas.cost\n\n val check_printable : string -> Gas.cost\n\n val merge_cycle : Gas.cost\n\n val parse_type_cycle : Gas.cost\n\n val parse_instr_cycle : Gas.cost\n\n val parse_data_cycle : Gas.cost\n\n val check_dupable_cycle : Gas.cost\n\n val find_entrypoint_cycle : Gas.cost\n\n val bool : Gas.cost\n\n val unit : Gas.cost\n\n val timestamp_readable : string -> Gas.cost\n\n val tx_rollup_l2_address : Gas.cost\n\n val contract_exists : Gas.cost\n\n val proof_argument : int -> Gas.cost\n\n val chest_key : Gas.cost\n\n val chest : bytes:int -> Gas.cost\n end\n\n module Unparsing : sig\n val public_key_optimized : Gas.cost\n\n val public_key_readable : Gas.cost\n\n val key_hash_optimized : Gas.cost\n\n val key_hash_readable : Gas.cost\n\n val signature_optimized : Gas.cost\n\n val signature_readable : Gas.cost\n\n val chain_id_optimized : Gas.cost\n\n val chain_id_readable : Gas.cost\n\n val timestamp_readable : Gas.cost\n\n val address_optimized : Gas.cost\n\n val contract_optimized : Gas.cost\n\n val contract_readable : Gas.cost\n\n val bls12_381_g1 : Gas.cost\n\n val bls12_381_g2 : Gas.cost\n\n val bls12_381_fr : Gas.cost\n\n val unparse_type : ('a, _) Script_typed_ir.ty -> Gas.cost\n\n val unparse_instr_cycle : Gas.cost\n\n val unparse_data_cycle : Gas.cost\n\n val unit : Gas.cost\n\n val tx_rollup_l2_address : Gas.cost\n\n val operation : bytes -> Gas.cost\n\n val sapling_transaction : Sapling.transaction -> Gas.cost\n\n val sapling_transaction_deprecated : Sapling.Legacy.transaction -> Gas.cost\n\n val sapling_diff : Sapling.diff -> Gas.cost\n\n val chest_key : Gas.cost\n\n val chest : plaintext_size:int -> Gas.cost\n end\nend\n\nmodule Internal_for_tests : sig\n (** [int] value of {!Cost_of.manager_operation} *)\n val int_cost_of_manager_operation : int\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2019-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* Copyright (c) 2022 DaiLambda, Inc. <contact@dailambda,jp> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\nopen Gas\nmodule S = Saturation_repr\nmodule Size = Gas_input_size\n\nmodule Cost_of = struct\n let z_bytes (z : Z.t) =\n let bits = Z.numbits z in\n (7 + bits) / 8\n\n let int_size_in_bytes (z : 'a Script_int.num) = z_bytes (Script_int.to_zint z)\n\n let manager_operation_int = 1_000\n\n let manager_operation = step_cost @@ S.safe_int manager_operation_int\n\n module Interpreter = struct\n open Michelson_v1_gas_costs\n\n let drop = atomic_step_cost cost_N_IDrop\n\n let dup = atomic_step_cost cost_N_IDup\n\n let swap = atomic_step_cost cost_N_ISwap\n\n let cons_some = atomic_step_cost cost_N_ICons_some\n\n let cons_none = atomic_step_cost cost_N_ICons_none\n\n let if_none = atomic_step_cost cost_N_IIf_none\n\n let opt_map = atomic_step_cost cost_N_IOpt_map\n\n let cons_pair = atomic_step_cost cost_N_ICons_pair\n\n let unpair = atomic_step_cost cost_N_IUnpair\n\n let car = atomic_step_cost cost_N_ICar\n\n let cdr = atomic_step_cost cost_N_ICdr\n\n let cons_left = atomic_step_cost cost_N_ILeft\n\n let cons_right = atomic_step_cost cost_N_IRight\n\n let if_left = atomic_step_cost cost_N_IIf_left\n\n let cons_list = atomic_step_cost cost_N_ICons_list\n\n let nil = atomic_step_cost cost_N_INil\n\n let if_cons = atomic_step_cost cost_N_IIf_cons\n\n let list_map : 'a Script_list.t -> Gas.cost =\n fun _ -> atomic_step_cost cost_N_IList_map\n\n let list_size = atomic_step_cost cost_N_IList_size\n\n let list_iter : 'a Script_list.t -> Gas.cost =\n fun _ -> atomic_step_cost cost_N_IList_iter\n\n let empty_set = atomic_step_cost cost_N_IEmpty_set\n\n let set_iter (type a) (set : a Script_typed_ir.set) =\n let (module Box) = Script_set.get set in\n atomic_step_cost (cost_N_ISet_iter Box.size)\n\n let set_size = atomic_step_cost cost_N_ISet_size\n\n let empty_map = atomic_step_cost cost_N_IEmpty_map\n\n let map_map (type k v) (map : (k, v) Script_typed_ir.map) =\n let (module Box) = Script_map.get_module map in\n atomic_step_cost (cost_N_IMap_map Box.size)\n\n let map_iter (type k v) (map : (k, v) Script_typed_ir.map) =\n let (module Box) = Script_map.get_module map in\n atomic_step_cost (cost_N_IMap_iter Box.size)\n\n let map_size = atomic_step_cost cost_N_IMap_size\n\n let big_map_elt_size = Script_expr_hash.size\n\n let big_map_mem ({size; _} : _ Script_typed_ir.big_map_overlay) =\n atomic_step_cost (cost_N_IMap_mem big_map_elt_size size)\n\n let big_map_get ({size; _} : _ Script_typed_ir.big_map_overlay) =\n atomic_step_cost (cost_N_IMap_get big_map_elt_size size)\n\n let big_map_update ({size; _} : _ Script_typed_ir.big_map_overlay) =\n atomic_step_cost (cost_N_IMap_update big_map_elt_size size)\n\n let big_map_get_and_update ({size; _} : _ Script_typed_ir.big_map_overlay) =\n atomic_step_cost (cost_N_IMap_get_and_update big_map_elt_size size)\n\n let add_seconds_timestamp :\n 'a Script_int.num -> Script_timestamp.t -> Gas.cost =\n fun seconds timestamp ->\n let seconds_bytes = int_size_in_bytes seconds in\n let timestamp_bytes = z_bytes (Script_timestamp.to_zint timestamp) in\n atomic_step_cost\n (cost_N_IAdd_seconds_to_timestamp seconds_bytes timestamp_bytes)\n\n let add_timestamp_seconds :\n Script_timestamp.t -> 'a Script_int.num -> Gas.cost =\n fun timestamp seconds ->\n let seconds_bytes = int_size_in_bytes seconds in\n let timestamp_bytes = z_bytes (Script_timestamp.to_zint timestamp) in\n atomic_step_cost\n (cost_N_IAdd_timestamp_to_seconds timestamp_bytes seconds_bytes)\n\n let sub_timestamp_seconds :\n Script_timestamp.t -> 'a Script_int.num -> Gas.cost =\n fun timestamp seconds ->\n let seconds_bytes = int_size_in_bytes seconds in\n let timestamp_bytes = z_bytes (Script_timestamp.to_zint timestamp) in\n atomic_step_cost\n (cost_N_ISub_timestamp_seconds timestamp_bytes seconds_bytes)\n\n let diff_timestamps t1 t2 =\n let t1_bytes = z_bytes (Script_timestamp.to_zint t1) in\n let t2_bytes = z_bytes (Script_timestamp.to_zint t2) in\n atomic_step_cost (cost_N_IDiff_timestamps t1_bytes t2_bytes)\n\n let concat_string_pair s1 s2 =\n atomic_step_cost\n (cost_N_IConcat_string_pair\n (Script_string.length s1)\n (Script_string.length s2))\n\n let slice_string s =\n atomic_step_cost (cost_N_ISlice_string (Script_string.length s))\n\n let string_size = atomic_step_cost cost_N_IString_size\n\n let concat_bytes_pair b1 b2 =\n atomic_step_cost\n (cost_N_IConcat_bytes_pair (Bytes.length b1) (Bytes.length b2))\n\n let slice_bytes b = atomic_step_cost (cost_N_ISlice_bytes (Bytes.length b))\n\n let bytes_size = atomic_step_cost cost_N_IBytes_size\n\n let lsl_bytes input nbits =\n match Script_int.to_int nbits with\n | None -> Saturation_repr.saturated\n | Some nbits ->\n atomic_step_cost (cost_N_ILsl_bytes (Bytes.length input) nbits)\n\n let lsr_bytes input nbits =\n let input_nbytes = Bytes.length input in\n let nbits =\n Option.value (Script_int.to_int nbits) ~default:(input_nbytes * 8)\n in\n atomic_step_cost (cost_N_ILsr_bytes input_nbytes nbits)\n\n let or_bytes b1 b2 =\n atomic_step_cost (cost_N_IOr_bytes (Bytes.length b1) (Bytes.length b2))\n\n let and_bytes b1 b2 =\n atomic_step_cost (cost_N_IAnd_bytes (Bytes.length b1) (Bytes.length b2))\n\n let xor_bytes b1 b2 =\n atomic_step_cost (cost_N_IXor_bytes (Bytes.length b1) (Bytes.length b2))\n\n let not_bytes b = atomic_step_cost (cost_N_INot_bytes (Bytes.length b))\n\n let bytes_nat n = atomic_step_cost (cost_N_IBytes_nat (int_size_in_bytes n))\n\n let nat_bytes b = atomic_step_cost (cost_N_INat_bytes (Bytes.length b))\n\n let bytes_int n = atomic_step_cost (cost_N_IBytes_int (int_size_in_bytes n))\n\n let int_bytes b = atomic_step_cost (cost_N_IInt_bytes (Bytes.length b))\n\n let add_tez = atomic_step_cost cost_N_IAdd_tez\n\n let sub_tez = atomic_step_cost cost_N_ISub_tez\n\n let sub_tez_legacy = atomic_step_cost cost_N_ISub_tez_legacy\n\n let mul_teznat = atomic_step_cost cost_N_IMul_teznat\n\n let mul_nattez = atomic_step_cost cost_N_IMul_nattez\n\n let bool_or = atomic_step_cost cost_N_IOr\n\n let bool_and = atomic_step_cost cost_N_IAnd\n\n let bool_xor = atomic_step_cost cost_N_IXor\n\n let bool_not = atomic_step_cost cost_N_INot\n\n let is_nat = atomic_step_cost cost_N_IIs_nat\n\n let abs_int i = atomic_step_cost (cost_N_IAbs_int (int_size_in_bytes i))\n\n let int_nat = atomic_step_cost cost_N_IInt_nat\n\n let neg i = atomic_step_cost (cost_N_INeg (int_size_in_bytes i))\n\n let add_int i1 i2 =\n atomic_step_cost\n (cost_N_IAdd_int (int_size_in_bytes i1) (int_size_in_bytes i2))\n\n let add_nat i1 i2 =\n atomic_step_cost\n (cost_N_IAdd_nat (int_size_in_bytes i1) (int_size_in_bytes i2))\n\n let sub_int i1 i2 =\n atomic_step_cost\n (cost_N_ISub_int (int_size_in_bytes i1) (int_size_in_bytes i2))\n\n let mul_int i1 i2 =\n atomic_step_cost\n (cost_N_IMul_int (int_size_in_bytes i1) (int_size_in_bytes i2))\n\n let mul_nat i1 i2 =\n atomic_step_cost\n (cost_N_IMul_nat (int_size_in_bytes i1) (int_size_in_bytes i2))\n\n let ediv_teznat _tez _n = atomic_step_cost cost_N_IEdiv_teznat\n\n let ediv_tez = atomic_step_cost cost_N_IEdiv_tez\n\n let ediv_int i1 i2 =\n atomic_step_cost\n (cost_N_IEdiv_int (int_size_in_bytes i1) (int_size_in_bytes i2))\n\n let ediv_nat i1 i2 =\n atomic_step_cost\n (cost_N_IEdiv_nat (int_size_in_bytes i1) (int_size_in_bytes i2))\n\n let eq = atomic_step_cost cost_N_IEq\n\n let lsl_nat shifted =\n atomic_step_cost (cost_N_ILsl_nat (int_size_in_bytes shifted))\n\n let lsr_nat shifted =\n atomic_step_cost (cost_N_ILsr_nat (int_size_in_bytes shifted))\n\n let or_nat n1 n2 =\n atomic_step_cost\n (cost_N_IOr_nat (int_size_in_bytes n1) (int_size_in_bytes n2))\n\n let and_nat n1 n2 =\n atomic_step_cost\n (cost_N_IAnd_nat (int_size_in_bytes n1) (int_size_in_bytes n2))\n\n let and_int_nat n1 n2 =\n atomic_step_cost\n (cost_N_IAnd_int_nat (int_size_in_bytes n1) (int_size_in_bytes n2))\n\n let xor_nat n1 n2 =\n atomic_step_cost\n (cost_N_IXor_nat (int_size_in_bytes n1) (int_size_in_bytes n2))\n\n let not_int i = atomic_step_cost (cost_N_INot_int (int_size_in_bytes i))\n\n let if_ = atomic_step_cost cost_N_IIf\n\n let loop = atomic_step_cost cost_N_ILoop\n\n let loop_left = atomic_step_cost cost_N_ILoop_left\n\n let dip = atomic_step_cost cost_N_IDip\n\n let view = atomic_step_cost cost_N_IView\n\n let check_signature (pkey : Signature.public_key) b =\n let cost =\n match pkey with\n | Ed25519 _ -> cost_N_ICheck_signature_ed25519 (Bytes.length b)\n | Secp256k1 _ -> cost_N_ICheck_signature_secp256k1 (Bytes.length b)\n | P256 _ -> cost_N_ICheck_signature_p256 (Bytes.length b)\n | Bls _ -> cost_N_ICheck_signature_bls (Bytes.length b)\n in\n atomic_step_cost cost\n\n let blake2b b = atomic_step_cost (cost_N_IBlake2b (Bytes.length b))\n\n let sha256 b = atomic_step_cost (cost_N_ISha256 (Bytes.length b))\n\n let sha512 b = atomic_step_cost (cost_N_ISha512 (Bytes.length b))\n\n let dign n = atomic_step_cost (cost_N_IDig n)\n\n let dugn n = atomic_step_cost (cost_N_IDug n)\n\n let dipn n = atomic_step_cost (cost_N_IDipN n)\n\n let dropn n = atomic_step_cost (cost_N_IDropN n)\n\n let voting_power = atomic_step_cost cost_N_IVoting_power\n\n let total_voting_power = atomic_step_cost cost_N_ITotal_voting_power\n\n let keccak b = atomic_step_cost (cost_N_IKeccak (Bytes.length b))\n\n let sha3 b = atomic_step_cost (cost_N_ISha3 (Bytes.length b))\n\n let add_bls12_381_g1 = atomic_step_cost cost_N_IAdd_bls12_381_g1\n\n let add_bls12_381_g2 = atomic_step_cost cost_N_IAdd_bls12_381_g2\n\n let add_bls12_381_fr = atomic_step_cost cost_N_IAdd_bls12_381_fr\n\n let mul_bls12_381_g1 = atomic_step_cost cost_N_IMul_bls12_381_g1\n\n let mul_bls12_381_g2 = atomic_step_cost cost_N_IMul_bls12_381_g2\n\n let mul_bls12_381_fr = atomic_step_cost cost_N_IMul_bls12_381_fr\n\n let mul_bls12_381_fr_z z =\n atomic_step_cost (cost_N_IMul_bls12_381_fr_z (int_size_in_bytes z))\n\n let mul_bls12_381_z_fr z =\n atomic_step_cost (cost_N_IMul_bls12_381_z_fr (int_size_in_bytes z))\n\n let int_bls12_381_fr = atomic_step_cost cost_N_IInt_bls12_381_z_fr\n\n let neg_bls12_381_g1 = atomic_step_cost cost_N_INeg_bls12_381_g1\n\n let neg_bls12_381_g2 = atomic_step_cost cost_N_INeg_bls12_381_g2\n\n let neg_bls12_381_fr = atomic_step_cost cost_N_INeg_bls12_381_fr\n\n let neq = atomic_step_cost cost_N_INeq\n\n let pairing_check_bls12_381 (l : 'a Script_list.t) =\n atomic_step_cost (cost_N_IPairing_check_bls12_381 l.length)\n\n let comb n = atomic_step_cost (cost_N_IComb n)\n\n let uncomb n = atomic_step_cost (cost_N_IUncomb n)\n\n let comb_get n = atomic_step_cost (cost_N_IComb_get n)\n\n let comb_set n = atomic_step_cost (cost_N_IComb_set n)\n\n let dupn n = atomic_step_cost (cost_N_IDupN n)\n\n let sapling_verify_update ~inputs ~outputs ~bound_data =\n atomic_step_cost (cost_N_ISapling_verify_update inputs outputs bound_data)\n\n let sapling_verify_update_deprecated ~inputs ~outputs =\n atomic_step_cost (cost_N_ISapling_verify_update inputs outputs 0)\n\n let sapling_empty_state = atomic_step_cost cost_N_ISapling_empty_state\n\n let halt = atomic_step_cost cost_N_IHalt\n\n let const = atomic_step_cost cost_N_IConst\n\n let empty_big_map = atomic_step_cost cost_N_IEmpty_big_map\n\n let lt = atomic_step_cost cost_N_ILt\n\n let le = atomic_step_cost cost_N_ILe\n\n let gt = atomic_step_cost cost_N_IGt\n\n let ge = atomic_step_cost cost_N_IGe\n\n let exec = atomic_step_cost cost_N_IExec\n\n let apply ~(rec_flag : bool) = atomic_step_cost (cost_N_IApply rec_flag)\n\n let lambda = atomic_step_cost cost_N_ILambda\n\n let address = atomic_step_cost cost_N_IAddress\n\n let contract = atomic_step_cost cost_N_IContract\n\n let transfer_tokens = atomic_step_cost cost_N_ITransfer_tokens\n\n let implicit_account = atomic_step_cost cost_N_IImplicit_account\n\n let create_contract = atomic_step_cost cost_N_ICreate_contract\n\n let set_delegate = atomic_step_cost cost_N_ISet_delegate\n\n let level = atomic_step_cost cost_N_ILevel\n\n let now = atomic_step_cost cost_N_INow\n\n let min_block_time = atomic_step_cost cost_N_IMin_block_time\n\n let source = atomic_step_cost cost_N_ISource\n\n let sender = atomic_step_cost cost_N_ISender\n\n let self = atomic_step_cost cost_N_ISelf\n\n let self_address = atomic_step_cost cost_N_ISelf_address\n\n let amount = atomic_step_cost cost_N_IAmount\n\n let balance = atomic_step_cost cost_N_IBalance\n\n let chain_id = atomic_step_cost cost_N_IChainId\n\n let ticket = atomic_step_cost cost_N_ITicket\n\n let read_ticket = atomic_step_cost cost_N_IRead_ticket\n\n let hash_key _ = atomic_step_cost cost_N_IHash_key\n\n let split_ticket amount_a amount_b =\n atomic_step_cost\n (cost_N_ISplit_ticket\n (int_size_in_bytes amount_a)\n (int_size_in_bytes amount_b))\n\n let open_chest ~chest ~time =\n let plaintext =\n Script_typed_ir.Script_timelock.get_plaintext_size chest\n in\n let log_time = Z.log2 Z.(add one time) in\n atomic_step_cost (cost_N_IOpen_chest log_time plaintext)\n\n (* --------------------------------------------------------------------- *)\n (* Semi-hand-crafted models *)\n\n let compare_unit = atomic_step_cost (S.safe_int 10)\n\n let compare_pair_tag = atomic_step_cost (S.safe_int 10)\n\n let compare_union_tag = atomic_step_cost (S.safe_int 10)\n\n let compare_option_tag = atomic_step_cost (S.safe_int 10)\n\n let compare_bool = atomic_step_cost (cost_N_ICompare 1 1)\n\n let compare_signature = atomic_step_cost (S.safe_int 92)\n\n let compare_string s1 s2 =\n atomic_step_cost\n (cost_N_ICompare (Script_string.length s1) (Script_string.length s2))\n\n let compare_bytes b1 b2 =\n atomic_step_cost (cost_N_ICompare (Bytes.length b1) (Bytes.length b2))\n\n let compare_mutez = atomic_step_cost (cost_N_ICompare 8 8)\n\n let compare_int i1 i2 =\n atomic_step_cost\n (cost_N_ICompare (int_size_in_bytes i1) (int_size_in_bytes i2))\n\n let compare_nat n1 n2 =\n atomic_step_cost\n (cost_N_ICompare (int_size_in_bytes n1) (int_size_in_bytes n2))\n\n let compare_key_hash =\n let sz = Signature.Public_key_hash.size in\n atomic_step_cost (cost_N_ICompare sz sz)\n\n let compare_key = atomic_step_cost (S.safe_int 92)\n\n let compare_timestamp t1 t2 =\n atomic_step_cost\n (cost_N_ICompare\n (z_bytes (Script_timestamp.to_zint t1))\n (z_bytes (Script_timestamp.to_zint t2)))\n\n (* Maximum size of an entrypoint in bytes *)\n let entrypoint_size = 31\n\n let compare_address =\n let sz = Signature.Public_key_hash.size + entrypoint_size in\n atomic_step_cost (cost_N_ICompare sz sz)\n\n (** TODO: https://gitlab.com/tezos/tezos/-/issues/2340\n Refine the gas model *)\n let compare_tx_rollup_l2_address = atomic_step_cost (cost_N_ICompare 48 48)\n\n let compare_chain_id = atomic_step_cost (S.safe_int 30)\n\n (* Defunctionalized CPS *)\n type cont =\n | Compare : 'a Script_typed_ir.comparable_ty * 'a * 'a * cont -> cont\n | Return : cont\n\n let compare : type a. a Script_typed_ir.comparable_ty -> a -> a -> cost =\n fun ty x y ->\n let rec compare :\n type a.\n a Script_typed_ir.comparable_ty -> a -> a -> cost -> cont -> cost =\n fun ty x y acc k ->\n match ty with\n | Unit_t -> (apply [@tailcall]) Gas.(acc +@ compare_unit) k\n | Never_t -> ( match x with _ -> .)\n | Bool_t -> (apply [@tailcall]) Gas.(acc +@ compare_bool) k\n | String_t -> (apply [@tailcall]) Gas.(acc +@ compare_string x y) k\n | Signature_t -> (apply [@tailcall]) Gas.(acc +@ compare_signature) k\n | Bytes_t -> (apply [@tailcall]) Gas.(acc +@ compare_bytes x y) k\n | Mutez_t -> (apply [@tailcall]) Gas.(acc +@ compare_mutez) k\n | Int_t -> (apply [@tailcall]) Gas.(acc +@ compare_int x y) k\n | Nat_t -> (apply [@tailcall]) Gas.(acc +@ compare_nat x y) k\n | Key_hash_t -> (apply [@tailcall]) Gas.(acc +@ compare_key_hash) k\n | Key_t -> (apply [@tailcall]) Gas.(acc +@ compare_key) k\n | Timestamp_t ->\n (apply [@tailcall]) Gas.(acc +@ compare_timestamp x y) k\n | Address_t -> (apply [@tailcall]) Gas.(acc +@ compare_address) k\n | Tx_rollup_l2_address_t ->\n (apply [@tailcall]) Gas.(acc +@ compare_tx_rollup_l2_address) k\n | Chain_id_t -> (apply [@tailcall]) Gas.(acc +@ compare_chain_id) k\n | Pair_t (tl, tr, _, YesYes) ->\n (* Reasonable over-approximation of the cost of lexicographic comparison. *)\n let xl, xr = x in\n let yl, yr = y in\n (compare [@tailcall])\n tl\n xl\n yl\n Gas.(acc +@ compare_pair_tag)\n (Compare (tr, xr, yr, k))\n | Union_t (tl, tr, _, YesYes) -> (\n match (x, y) with\n | L x, L y ->\n (compare [@tailcall]) tl x y Gas.(acc +@ compare_union_tag) k\n | L _, R _ -> (apply [@tailcall]) Gas.(acc +@ compare_union_tag) k\n | R _, L _ -> (apply [@tailcall]) Gas.(acc +@ compare_union_tag) k\n | R x, R y ->\n (compare [@tailcall]) tr x y Gas.(acc +@ compare_union_tag) k)\n | Option_t (t, _, Yes) -> (\n match (x, y) with\n | None, None ->\n (apply [@tailcall]) Gas.(acc +@ compare_option_tag) k\n | None, Some _ ->\n (apply [@tailcall]) Gas.(acc +@ compare_option_tag) k\n | Some _, None ->\n (apply [@tailcall]) Gas.(acc +@ compare_option_tag) k\n | Some x, Some y ->\n (compare [@tailcall]) t x y Gas.(acc +@ compare_option_tag) k)\n and apply cost k =\n match k with\n | Compare (ty, x, y, k) -> (compare [@tailcall]) ty x y cost k\n | Return -> cost\n in\n compare ty x y Gas.free Return\n\n let set_mem (type a) (elt : a) (set : a Script_typed_ir.set) =\n let open S.Syntax in\n let (module Box) = Script_set.get set in\n let per_elt_cost = Box.OPS.elt_size elt |> Size.to_int |> S.safe_int in\n let size = S.safe_int Box.size in\n let intercept = atomic_step_cost (S.safe_int 115) in\n Gas.(intercept +@ (log2 size *@ per_elt_cost))\n\n let set_update (type a) (elt : a) (set : a Script_typed_ir.set) =\n let open S.Syntax in\n let (module Box) = Script_set.get set in\n let per_elt_cost = Box.OPS.elt_size elt |> Size.to_int |> S.safe_int in\n let size = S.safe_int Box.size in\n let intercept = atomic_step_cost (S.safe_int 130) in\n (* The 2 factor reflects the update vs mem overhead as benchmarked\n on non-structured data *)\n Gas.(intercept +@ (S.safe_int 2 * log2 size *@ per_elt_cost))\n\n let map_mem (type k v) (elt : k) (map : (k, v) Script_typed_ir.map) =\n let open S.Syntax in\n let (module Box) = Script_map.get_module map in\n let per_elt_cost = Box.OPS.key_size elt |> Size.to_int |> S.safe_int in\n let size = S.safe_int Box.size in\n let intercept = atomic_step_cost (S.safe_int 80) in\n Gas.(intercept +@ (log2 size *@ per_elt_cost))\n\n let map_get = map_mem\n\n let map_update (type k v) (elt : k) (map : (k, v) Script_typed_ir.map) =\n let open S.Syntax in\n let (module Box) = Script_map.get_module map in\n let per_elt_cost = Box.OPS.key_size elt |> Size.to_int |> S.safe_int in\n let size = S.safe_int Box.size in\n let intercept = atomic_step_cost (S.safe_int 80) in\n (* The 2 factor reflects the update vs mem overhead as benchmarked\n on non-structured data *)\n Gas.(intercept +@ (S.safe_int 2 * log2 size *@ per_elt_cost))\n\n let map_get_and_update (type k v) (elt : k)\n (map : (k, v) Script_typed_ir.map) =\n let open S.Syntax in\n let (module Box) = Script_map.get_module map in\n let per_elt_cost = Box.OPS.key_size elt |> Size.to_int |> S.safe_int in\n let size = S.safe_int Box.size in\n let intercept = atomic_step_cost (S.safe_int 80) in\n (* The 3 factor reflects the update vs mem overhead as benchmarked\n on non-structured data *)\n Gas.(intercept +@ (S.safe_int 3 * log2 size *@ per_elt_cost))\n\n let view_get (elt : Script_string.t) (m : Script_typed_ir.view_map) =\n map_get elt m\n\n let view_update (elt : Script_string.t) (m : Script_typed_ir.view_map) =\n map_update elt m\n\n let join_tickets :\n 'a Script_typed_ir.comparable_ty ->\n 'a Script_typed_ir.ticket ->\n 'a Script_typed_ir.ticket ->\n Gas.cost =\n fun ty ticket_a ticket_b ->\n let contents_comparison =\n compare ty ticket_a.contents ticket_b.contents\n in\n Gas.(\n contents_comparison +@ compare_address\n +@ add_nat\n (ticket_a.amount :> Script_int.n Script_int.num)\n (ticket_b.amount :> Script_int.n Script_int.num))\n\n let emit = atomic_step_cost cost_N_IEmit\n\n (* Continuations *)\n module Control = struct\n let nil = atomic_step_cost cost_N_KNil\n\n let cons = atomic_step_cost cost_N_KCons\n\n let return = atomic_step_cost cost_N_KReturn\n\n let view_exit = atomic_step_cost cost_N_KView_exit\n\n let map_head = atomic_step_cost cost_N_KMap_head\n\n let undip = atomic_step_cost cost_N_KUndip\n\n let loop_in = atomic_step_cost cost_N_KLoop_in\n\n let loop_in_left = atomic_step_cost cost_N_KLoop_in_left\n\n let iter = atomic_step_cost cost_N_KIter\n\n let list_enter_body xs ys_len =\n atomic_step_cost (cost_N_KList_enter_body xs ys_len)\n\n let list_exit_body = atomic_step_cost cost_N_KList_exit_body\n\n let map_enter_body = atomic_step_cost cost_N_KMap_enter_body\n\n let map_exit_body (type k v) (key : k) (map : (k, v) Script_typed_ir.map)\n =\n map_update key map\n end\n\n (* --------------------------------------------------------------------- *)\n (* Hand-crafted models *)\n\n (* The cost functions below where not benchmarked, a cost model was derived\n from looking at similar instructions. *)\n\n (* Cost for Concat_string is paid in two steps: when entering the interpreter,\n the user pays for the cost of computing the information necessary to compute\n the actual gas (so it's meta-gas): indeed, one needs to run through the\n list of strings to compute the total allocated cost.\n [concat_string_precheck] corresponds to the meta-gas cost of this computation.\n *)\n let concat_string_precheck (l : 'a Script_list.t) =\n (* we set the precheck to be slightly more expensive than cost_N_IList_iter *)\n atomic_step_cost (S.mul (S.safe_int l.length) (S.safe_int 10))\n\n (* This is the cost of allocating a string and blitting existing ones into it. *)\n let concat_string total_bytes =\n atomic_step_cost S.(add (S.safe_int 100) (S.shift_right total_bytes 1))\n\n (* Same story as Concat_string. *)\n let concat_bytes total_bytes =\n atomic_step_cost S.(add (S.safe_int 100) (S.shift_right total_bytes 1))\n\n (* Cost of Unpack pays two integer comparisons, and a Bytes slice *)\n let unpack bytes =\n let blen = Bytes.length bytes in\n let open S.Syntax in\n atomic_step_cost (S.safe_int 260 + (S.safe_int blen lsr 1))\n\n (* TODO benchmark *)\n (* FIXME: imported from 006, needs proper benchmarks *)\n let unpack_failed bytes =\n (* We cannot instrument failed deserialization,\n so we take worst case fees: a set of size 1 bytes values. *)\n let blen = String.length bytes in\n let len = S.safe_int blen in\n let d = Z.numbits (Z.of_int blen) in\n (len *@ alloc_mbytes_cost 1)\n +@ len\n *@ (S.safe_int d *@ (alloc_cost (S.safe_int 3) +@ step_cost S.one))\n end\n\n module Typechecking = struct\n open Michelson_v1_gas_costs\n\n let public_key_optimized =\n atomic_step_cost\n @@ S.(\n max\n cost_DECODING_PUBLIC_KEY_ed25519\n (max\n cost_DECODING_PUBLIC_KEY_secp256k1\n (max cost_DECODING_PUBLIC_KEY_p256 cost_DECODING_PUBLIC_KEY_bls)))\n\n let public_key_readable =\n atomic_step_cost\n @@ S.(\n max\n cost_B58CHECK_DECODING_PUBLIC_KEY_ed25519\n (max\n cost_B58CHECK_DECODING_PUBLIC_KEY_secp256k1\n (max\n cost_B58CHECK_DECODING_PUBLIC_KEY_p256\n cost_B58CHECK_DECODING_PUBLIC_KEY_bls)))\n\n let key_hash_optimized =\n atomic_step_cost\n @@ S.(\n max\n cost_DECODING_PUBLIC_KEY_HASH_ed25519\n (max\n cost_DECODING_PUBLIC_KEY_HASH_secp256k1\n (max\n cost_DECODING_PUBLIC_KEY_HASH_p256\n cost_DECODING_PUBLIC_KEY_HASH_bls)))\n\n let key_hash_readable =\n atomic_step_cost\n @@ S.(\n max\n cost_B58CHECK_DECODING_PUBLIC_KEY_HASH_ed25519\n (max\n cost_B58CHECK_DECODING_PUBLIC_KEY_HASH_secp256k1\n (max\n cost_B58CHECK_DECODING_PUBLIC_KEY_HASH_p256\n cost_B58CHECK_DECODING_PUBLIC_KEY_HASH_bls)))\n\n let signature_optimized =\n atomic_step_cost\n @@ S.(\n max\n cost_DECODING_SIGNATURE_ed25519\n (max\n cost_DECODING_SIGNATURE_secp256k1\n (max cost_DECODING_SIGNATURE_p256 cost_DECODING_SIGNATURE_bls)))\n\n let signature_readable =\n atomic_step_cost\n @@ S.(\n max\n cost_B58CHECK_DECODING_SIGNATURE_ed25519\n (max\n cost_B58CHECK_DECODING_SIGNATURE_secp256k1\n (max\n cost_B58CHECK_DECODING_SIGNATURE_p256\n cost_B58CHECK_DECODING_SIGNATURE_bls)))\n\n let chain_id_optimized = atomic_step_cost cost_DECODING_CHAIN_ID\n\n let chain_id_readable = atomic_step_cost cost_B58CHECK_DECODING_CHAIN_ID\n\n (* Reasonable approximation *)\n let address_optimized = key_hash_optimized\n\n (* Reasonable approximation *)\n let contract_optimized = key_hash_optimized\n\n (* Reasonable approximation *)\n let contract_readable = key_hash_readable\n\n let bls12_381_g1 = atomic_step_cost cost_DECODING_BLS_G1\n\n let bls12_381_g2 = atomic_step_cost cost_DECODING_BLS_G2\n\n let bls12_381_fr = atomic_step_cost cost_DECODING_BLS_FR\n\n let check_printable s =\n atomic_step_cost (cost_CHECK_PRINTABLE (String.length s))\n\n let merge_cycle = atomic_step_cost cost_TY_EQ\n\n let parse_type_cycle = atomic_step_cost cost_PARSE_TYPE\n\n let parse_instr_cycle = atomic_step_cost cost_TYPECHECKING_CODE\n\n let parse_data_cycle = atomic_step_cost cost_TYPECHECKING_DATA\n\n (* Cost of a cycle of checking that a type is dupable *)\n (* TODO: bench *)\n let check_dupable_cycle = atomic_step_cost cost_TYPECHECKING_DATA\n\n let find_entrypoint_cycle = atomic_step_cost cost_FIND_ENTRYPOINT\n\n let bool = free\n\n let unit = free\n\n let timestamp_readable s =\n atomic_step_cost (cost_TIMESTAMP_READABLE_DECODING (String.length s))\n\n (** TODO: https://gitlab.com/tezos/tezos/-/issues/2340\n Refine the gas model *)\n let tx_rollup_l2_address = bls12_381_g1\n\n (* Balance stored at /contracts/index/hash/balance, on 64 bits *)\n let contract_exists =\n Gas.cost_of_repr @@ Storage_costs.read_access ~path_length:4 ~read_bytes:8\n\n (* Constructing proof arguments consists in a decreasing loop in the result\n monad, allocating at each step. We charge a reasonable overapproximation. *)\n let proof_argument n =\n atomic_step_cost (S.mul (S.safe_int n) (S.safe_int 50))\n\n let chest_key = atomic_step_cost cost_DECODING_Chest_key\n\n let chest ~bytes = atomic_step_cost (cost_DECODING_Chest bytes)\n end\n\n module Unparsing = struct\n open Michelson_v1_gas_costs\n\n let public_key_optimized =\n atomic_step_cost\n @@ S.(\n max\n cost_ENCODING_PUBLIC_KEY_ed25519\n (max\n cost_ENCODING_PUBLIC_KEY_secp256k1\n (max cost_ENCODING_PUBLIC_KEY_p256 cost_ENCODING_PUBLIC_KEY_bls)))\n\n let public_key_readable =\n atomic_step_cost\n @@ S.(\n max\n cost_B58CHECK_ENCODING_PUBLIC_KEY_ed25519\n (max\n cost_B58CHECK_ENCODING_PUBLIC_KEY_secp256k1\n (max\n cost_B58CHECK_ENCODING_PUBLIC_KEY_p256\n cost_B58CHECK_ENCODING_PUBLIC_KEY_bls)))\n\n let key_hash_optimized =\n atomic_step_cost\n @@ S.(\n max\n cost_ENCODING_PUBLIC_KEY_HASH_ed25519\n (max\n cost_ENCODING_PUBLIC_KEY_HASH_secp256k1\n (max\n cost_ENCODING_PUBLIC_KEY_HASH_p256\n cost_ENCODING_PUBLIC_KEY_HASH_bls)))\n\n let key_hash_readable =\n atomic_step_cost\n @@ S.(\n max\n cost_B58CHECK_ENCODING_PUBLIC_KEY_HASH_ed25519\n (max\n cost_B58CHECK_ENCODING_PUBLIC_KEY_HASH_secp256k1\n (max\n cost_B58CHECK_ENCODING_PUBLIC_KEY_HASH_p256\n cost_B58CHECK_ENCODING_PUBLIC_KEY_HASH_bls)))\n\n let signature_optimized =\n atomic_step_cost\n @@ S.(\n max\n cost_ENCODING_SIGNATURE_ed25519\n (max\n cost_ENCODING_SIGNATURE_secp256k1\n (max cost_ENCODING_SIGNATURE_p256 cost_ENCODING_SIGNATURE_bls)))\n\n let signature_readable =\n atomic_step_cost\n @@ S.(\n max\n cost_B58CHECK_ENCODING_SIGNATURE_ed25519\n (max\n cost_B58CHECK_ENCODING_SIGNATURE_secp256k1\n (max\n cost_B58CHECK_ENCODING_SIGNATURE_p256\n cost_B58CHECK_ENCODING_SIGNATURE_bls)))\n\n let chain_id_optimized = atomic_step_cost cost_ENCODING_CHAIN_ID\n\n let chain_id_readable = atomic_step_cost cost_B58CHECK_ENCODING_CHAIN_ID\n\n let timestamp_readable = atomic_step_cost cost_TIMESTAMP_READABLE_ENCODING\n\n (* Reasonable approximation *)\n let address_optimized = key_hash_optimized\n\n (* Reasonable approximation *)\n let contract_optimized = key_hash_optimized\n\n (* Reasonable approximation *)\n let contract_readable = key_hash_readable\n\n let bls12_381_g1 = atomic_step_cost cost_ENCODING_BLS_G1\n\n let bls12_381_g2 = atomic_step_cost cost_ENCODING_BLS_G2\n\n let bls12_381_fr = atomic_step_cost cost_ENCODING_BLS_FR\n\n let unparse_type ty =\n atomic_step_cost\n @@ cost_UNPARSE_TYPE Script_typed_ir.(ty_size ty |> Type_size.to_int)\n\n let unparse_instr_cycle = atomic_step_cost cost_UNPARSING_CODE\n\n let unparse_data_cycle = atomic_step_cost cost_UNPARSING_DATA\n\n let unit = Gas.free\n\n (** TODO: https://gitlab.com/tezos/tezos/-/issues/2340\n Refine the gas model *)\n let tx_rollup_l2_address = bls12_381_g1\n\n (* Reuse 006 costs. *)\n let operation bytes = Script.bytes_node_cost bytes\n\n let sapling_transaction (t : Sapling.transaction) =\n let inputs = Size.sapling_transaction_inputs t in\n let outputs = Size.sapling_transaction_outputs t in\n let bound_data = Size.sapling_transaction_bound_data t in\n atomic_step_cost\n (cost_SAPLING_TRANSACTION_ENCODING ~inputs ~outputs ~bound_data)\n\n let sapling_transaction_deprecated (t : Sapling.Legacy.transaction) =\n let inputs = List.length t.inputs in\n let outputs = List.length t.outputs in\n atomic_step_cost\n (cost_SAPLING_TRANSACTION_ENCODING ~inputs ~outputs ~bound_data:0)\n\n let sapling_diff (d : Sapling.diff) =\n let nfs = List.length d.nullifiers in\n let cms = List.length d.commitments_and_ciphertexts in\n atomic_step_cost (cost_SAPLING_DIFF_ENCODING ~nfs ~cms)\n\n let chest_key = atomic_step_cost cost_ENCODING_Chest_key\n\n let chest ~plaintext_size =\n atomic_step_cost (cost_ENCODING_Chest plaintext_size)\n end\nend\n\nmodule Internal_for_tests = struct\n let int_cost_of_manager_operation = Cost_of.manager_operation_int\nend\n" ;
} ;
{ name = "Script_tc_context" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\nopen Script_typed_ir\n\n(** This module defines the typechecking context used during the translation\n from Michelson untyped nodes to typed nodes ([Script_ir_translator]).\n The context keeps track of the origin of the code (top-level from a contract,\n in a view, etc.), plus some information to allow or forbid instructions\n given the context (no `SELF` in a lambda for example). *)\n\n(** Lambdas are a bit special when considering stateful instructions such as\n [TRANSFER_TOKENS].\n For instance, a view containing a [TRANSFER_TOKENS] is not OK, because\n calling the view would transfer tokens from the view's owner.\n However, a view returning a lambda containing a [TRANSFER_TOKENS] could be\n considered OK, as the decision whether to execute it or not falls on\n the view's caller, whose tokens would be transfered.\n This type is used to keep track of whether we are inside a lambda: it is\n [true] when inside a lambda, and [false] otherwise. *)\ntype in_lambda = bool\n\n(** The calling context when parsing Michelson code: either a top-level contract\n code, the code of a view, or code in data (when pushing a block of\n instructions for example). *)\ntype callsite =\n | Toplevel : {\n storage_type : ('sto, _) ty;\n param_type : ('param, _) ty;\n entrypoints : 'param Script_typed_ir.entrypoints;\n }\n -> callsite\n | View : callsite\n | Data : callsite\n\ntype t = {callsite : callsite; in_lambda : in_lambda}\n\nval init : callsite -> t\n\nval toplevel :\n storage_type:('sto, _) ty ->\n param_type:('param, _) ty ->\n entrypoints:'param Script_typed_ir.entrypoints ->\n t\n\nval view : t\n\n(** This value can be used outside the translation module as a simple context\n when testing code, for example. *)\nval data : t\n\nval add_lambda : t -> t\n\nval is_in_lambda : t -> bool\n\nval check_not_in_view :\n Script.location -> legacy:bool -> t -> Script.prim -> unit tzresult\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Script_typed_ir\n\ntype in_lambda = bool\n\ntype callsite =\n | Toplevel : {\n storage_type : ('sto, _) ty;\n param_type : ('param, _) ty;\n entrypoints : 'param Script_typed_ir.entrypoints;\n }\n -> callsite\n | View : callsite\n | Data : callsite\n\ntype t = {callsite : callsite; in_lambda : in_lambda}\n\nlet init callsite = {callsite; in_lambda = false}\n\nlet toplevel ~storage_type ~param_type ~entrypoints =\n init (Toplevel {storage_type; param_type; entrypoints})\n\nlet view = init View\n\n(* [data] is prefered over [toplevel] outside [Script_ir_translator], because\n [toplevel] needs to setup a lot of information. *)\nlet data = init Data\n\nlet add_lambda tc_context = {tc_context with in_lambda = true}\n\nlet is_in_lambda {callsite = _; in_lambda} = in_lambda\n\nlet check_not_in_view loc ~legacy tc_context prim =\n match tc_context.callsite with\n (* The forbidden (stateful) instructions in views are in facts allowed in\n lambdas in views, because they could be returned to the caller, and then\n executed on his responsibility. *)\n | Toplevel _ | Data -> Result.return_unit\n | View when is_in_lambda tc_context || legacy -> Result.return_unit\n | View ->\n error Script_tc_errors.(Forbidden_instr_in_context (loc, View, prim))\n" ;
} ;
{ name = "Ticket_token" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\n(** A module for handling ticket-tokens. A ticket-token represents the\n combination of a ticketer (creator of a ticket) and the content. That is,\n a ticket comprises a ticket-token and an amount.\n *)\n\ntype 'a parsed_token = {\n ticketer : Contract.t;\n contents_type : 'a Script_typed_ir.comparable_ty;\n contents : 'a;\n}\n\n(** A type for representing existentially quantified ticket-tokens. A\n ticket-token consists of a pair of ticketer and contents. *)\ntype ex_token = Ex_token : 'a parsed_token -> ex_token\n\n(** Unparsed version of [parsed_token].\n Used to encode/decode ticket-token in receipt, RPC, etc. *)\ntype unparsed_token = {\n ticketer : Contract.t;\n contents_type : Script.expr;\n contents : Script.expr;\n}\n\nval unparsed_token_encoding : unparsed_token Data_encoding.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\ntype 'a parsed_token = {\n ticketer : Contract.t;\n contents_type : 'a Script_typed_ir.comparable_ty;\n contents : 'a;\n}\n\ntype ex_token = Ex_token : 'a parsed_token -> ex_token\n\ntype unparsed_token = {\n ticketer : Contract.t;\n contents_type : Script.expr;\n contents : Script.expr;\n}\n\nlet unparsed_token_encoding =\n let open Data_encoding in\n conv\n (fun {ticketer; contents_type; contents} ->\n (ticketer, contents_type, contents))\n (fun (ticketer, contents_type, contents) ->\n {ticketer; contents_type; contents})\n (obj3\n (req \"ticketer\" Contract.encoding)\n (req \"content_type\" Script.expr_encoding)\n (req \"content\" Script.expr_encoding))\n" ;
} ;
{ name = "Ticket_receipt" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\n(** A module for representing the increase/decrease of tickets in the storage.\n It will be used to display ticket update information in the operation receipt. *)\n\n(** Represents that [account]'s storage has delta [amount] for a given ticket *)\ntype update = {account : Destination.t; amount : Z.t}\n\n(** List of updates for a [ticket] *)\ntype item = {ticket_token : Ticket_token.unparsed_token; updates : update list}\n\n(** A list of ticket tokens and their corresponding updates *)\ntype t = item list\n\nval item_encoding : item Data_encoding.t\n\nval encoding : t Data_encoding.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\ntype update = {account : Destination.t; amount : Z.t}\n\ntype item = {ticket_token : Ticket_token.unparsed_token; updates : update list}\n\ntype t = item list\n\nlet update_encoding =\n let open Data_encoding in\n conv\n (fun {account; amount} -> (account, amount))\n (fun (account, amount) -> {account; amount})\n (obj2 (req \"account\" Destination.encoding) (req \"amount\" z))\n\nlet item_encoding =\n let open Data_encoding in\n conv\n (fun {ticket_token; updates} -> (ticket_token, updates))\n (fun (ticket_token, updates) -> {ticket_token; updates})\n (obj2\n (req \"ticket_token\" Ticket_token.unparsed_token_encoding)\n (req \"updates\" (list update_encoding)))\n\nlet encoding = Data_encoding.list item_encoding\n" ;
} ;
{ name = "Apply_operation_result" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** The result of an operation in the queue. [Skipped] ones should\n always be at the tail, and after a single [Failed].\n * The ['kind] parameter is the operation kind (a transaction, an\n origination, etc.).\n * The ['manager] parameter is the type of manager kinds.\n * The ['successful] parameter is the type of successful operations.\n The ['kind] parameter is used to make the type a GADT, but ['manager] and\n ['successful] are used to share [operation_result] between internal and\n external operation results, and are instantiated for each case. *)\ntype ('kind, 'manager, 'successful) operation_result =\n | Applied of 'successful\n | Backtracked of 'successful * error trace option\n | Failed :\n 'manager * error trace\n -> ('kind, 'manager, 'successful) operation_result\n | Skipped : 'manager -> ('kind, 'manager, 'successful) operation_result\n\nval trace_encoding : error trace Data_encoding.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Data_encoding\n\ntype ('kind, 'manager, 'successful) operation_result =\n | Applied of 'successful\n | Backtracked of 'successful * error trace option\n | Failed :\n 'manager * error trace\n -> ('kind, 'manager, 'successful) operation_result\n | Skipped : 'manager -> ('kind, 'manager, 'successful) operation_result\n\nlet error_encoding =\n def\n \"error\"\n ~description:\n \"The full list of RPC errors would be too long to include.\\n\\\n It is available at RPC `/errors` (GET).\\n\\\n Errors specific to protocol Alpha have an id that starts with \\\n `proto.alpha`.\"\n @@ splitted\n ~json:\n (conv\n (fun err ->\n Data_encoding.Json.construct Error_monad.error_encoding err)\n (fun json ->\n Data_encoding.Json.destruct Error_monad.error_encoding json)\n json)\n ~binary:Error_monad.error_encoding\n\nlet trace_encoding = make_trace_encoding error_encoding\n" ;
} ;
{ name = "Apply_internal_results" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Types representing results of applying an internal operation.\n\n These are used internally by [Apply].\n*)\n\nopen Alpha_context\n\n(** [internal_operation_contents] are the internal operations as output in\n receipts.\n The type simply weakens {!Script_typed_ir.internal_operation_contents} so\n that it is easier to define an encoding for it (i.e. we remove the typed\n parameter). *)\ntype 'kind internal_operation_contents =\n | Transaction : {\n amount : Tez.tez;\n parameters : Script.lazy_expr;\n entrypoint : Entrypoint.t;\n destination : Destination.t;\n }\n -> Kind.transaction internal_operation_contents\n | Origination : {\n delegate : Signature.Public_key_hash.t option;\n script : Script.t;\n credit : Tez.tez;\n }\n -> Kind.origination internal_operation_contents\n | Delegation :\n Signature.Public_key_hash.t option\n -> Kind.delegation internal_operation_contents\n | Event : {\n ty : Script.expr;\n tag : Entrypoint.t;\n payload : Script.expr;\n }\n -> Kind.event internal_operation_contents\n\ntype 'kind internal_operation = {\n source : Destination.t;\n operation : 'kind internal_operation_contents;\n nonce : int;\n}\n\ntype packed_internal_operation =\n | Internal_operation : 'kind internal_operation -> packed_internal_operation\n\nval packed_internal_operation :\n Script_typed_ir.packed_internal_operation -> packed_internal_operation\n\nval packed_internal_operations :\n Script_typed_ir.packed_internal_operation list ->\n packed_internal_operation list\n\n(** Result of applying an internal transaction. *)\ntype successful_transaction_result =\n | Transaction_to_contract_result of {\n storage : Script.expr option;\n lazy_storage_diff : Lazy_storage.diffs option;\n balance_updates : Receipt.balance_updates;\n ticket_receipt : Ticket_receipt.t;\n originated_contracts : Contract_hash.t list;\n consumed_gas : Gas.Arith.fp;\n storage_size : Z.t;\n paid_storage_size_diff : Z.t;\n allocated_destination_contract : bool;\n }\n | Transaction_to_tx_rollup_result of {\n ticket_hash : Ticket_hash.t;\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n paid_storage_size_diff : Z.t;\n }\n | Transaction_to_sc_rollup_result of {\n consumed_gas : Gas.Arith.fp;\n ticket_receipt : Ticket_receipt.t;\n }\n | Transaction_to_zk_rollup_result of {\n ticket_hash : Ticket_hash.t;\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n paid_storage_size_diff : Z.t;\n }\n\n(** Result of applying an internal origination. *)\ntype successful_origination_result = {\n lazy_storage_diff : Lazy_storage.diffs option;\n balance_updates : Receipt.balance_updates;\n originated_contracts : Contract_hash.t list;\n consumed_gas : Gas.Arith.fp;\n storage_size : Z.t;\n paid_storage_size_diff : Z.t;\n}\n\n(** Result of applying a {!Script_typed_ir.internal_operation_contents}. *)\ntype _ successful_internal_operation_result =\n | ITransaction_result :\n successful_transaction_result\n -> Kind.transaction successful_internal_operation_result\n | IOrigination_result :\n successful_origination_result\n -> Kind.origination successful_internal_operation_result\n | IDelegation_result : {\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.delegation successful_internal_operation_result\n | IEvent_result : {\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.event successful_internal_operation_result\n\ntype 'kind internal_operation_result =\n ( 'kind,\n 'kind Kind.manager,\n 'kind successful_internal_operation_result )\n Apply_operation_result.operation_result\n\ntype packed_internal_operation_result =\n | Internal_operation_result :\n 'kind internal_operation * 'kind internal_operation_result\n -> packed_internal_operation_result\n\nval internal_operation :\n 'kind Script_typed_ir.internal_operation -> 'kind internal_operation\n\nval pack_internal_operation_result :\n 'kind Script_typed_ir.internal_operation ->\n 'kind internal_operation_result ->\n packed_internal_operation_result\n\nval internal_operation_encoding : packed_internal_operation Data_encoding.t\n\nval internal_operation_result_encoding :\n packed_internal_operation_result Data_encoding.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\nopen Data_encoding\nopen Apply_operation_result\n\ntype 'kind internal_operation_contents =\n | Transaction : {\n amount : Tez.tez;\n parameters : Script.lazy_expr;\n entrypoint : Entrypoint.t;\n destination : Destination.t;\n }\n -> Kind.transaction internal_operation_contents\n | Origination : {\n delegate : Signature.Public_key_hash.t option;\n script : Script.t;\n credit : Tez.tez;\n }\n -> Kind.origination internal_operation_contents\n | Delegation :\n Signature.Public_key_hash.t option\n -> Kind.delegation internal_operation_contents\n | Event : {\n ty : Script.expr;\n tag : Entrypoint.t;\n payload : Script.expr;\n }\n -> Kind.event internal_operation_contents\n\ntype packed_internal_operation_contents =\n | Internal_operation_contents :\n 'kind internal_operation_contents\n -> packed_internal_operation_contents\n\ntype 'kind internal_operation = {\n source : Destination.t;\n operation : 'kind internal_operation_contents;\n nonce : int;\n}\n\ntype packed_internal_operation =\n | Internal_operation : 'kind internal_operation -> packed_internal_operation\n\nlet internal_operation (type kind)\n ({source; operation; nonce} : kind Script_typed_ir.internal_operation) :\n kind internal_operation =\n let operation : kind internal_operation_contents =\n match operation with\n | Transaction_to_implicit {destination; amount} ->\n Transaction\n {\n destination = Contract (Implicit destination);\n amount;\n entrypoint = Entrypoint.default;\n parameters = Script.unit_parameter;\n }\n | Transaction_to_implicit_with_ticket\n {destination; unparsed_ticket; amount; ticket_ty = _; ticket = _} ->\n Transaction\n {\n destination = Contract (Implicit destination);\n amount;\n entrypoint = Entrypoint.default;\n parameters = unparsed_ticket;\n }\n | Transaction_to_smart_contract\n {destination; amount; entrypoint; unparsed_parameters; _} ->\n Transaction\n {\n destination = Contract (Originated destination);\n amount;\n entrypoint;\n parameters = Script.lazy_expr unparsed_parameters;\n }\n | Transaction_to_tx_rollup {destination; unparsed_parameters; _} ->\n Transaction\n {\n destination = Tx_rollup destination;\n (* Dummy amount used for the external untyped view of internal transactions *)\n amount = Tez.zero;\n entrypoint = Entrypoint.deposit;\n parameters = Script.lazy_expr unparsed_parameters;\n }\n | Transaction_to_sc_rollup {destination; entrypoint; unparsed_parameters; _}\n ->\n Transaction\n {\n destination = Sc_rollup destination;\n amount = Tez.zero;\n entrypoint;\n parameters = Script.lazy_expr unparsed_parameters;\n }\n | Event {ty; tag; unparsed_data} -> Event {ty; tag; payload = unparsed_data}\n | Transaction_to_zk_rollup {destination; unparsed_parameters; _} ->\n Transaction\n {\n destination = Zk_rollup destination;\n amount = Tez.zero;\n entrypoint = Entrypoint.deposit;\n parameters = Script.lazy_expr unparsed_parameters;\n }\n | Origination {delegate; code; unparsed_storage; credit; _} ->\n let script =\n {\n Script.code = Script.lazy_expr code;\n storage = Script.lazy_expr unparsed_storage;\n }\n in\n Origination {delegate; script; credit}\n | Delegation delegate -> Delegation delegate\n in\n {source; operation; nonce}\n\nlet packed_internal_operation (Script_typed_ir.Internal_operation op) =\n Internal_operation (internal_operation op)\n\nlet packed_internal_operations = List.map packed_internal_operation\n\ntype successful_transaction_result =\n | Transaction_to_contract_result of {\n storage : Script.expr option;\n lazy_storage_diff : Lazy_storage.diffs option;\n balance_updates : Receipt.balance_updates;\n ticket_receipt : Ticket_receipt.t;\n originated_contracts : Contract_hash.t list;\n consumed_gas : Gas.Arith.fp;\n storage_size : Z.t;\n paid_storage_size_diff : Z.t;\n allocated_destination_contract : bool;\n }\n | Transaction_to_tx_rollup_result of {\n ticket_hash : Ticket_hash.t;\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n paid_storage_size_diff : Z.t;\n }\n | Transaction_to_sc_rollup_result of {\n consumed_gas : Gas.Arith.fp;\n ticket_receipt : Ticket_receipt.t;\n }\n | Transaction_to_zk_rollup_result of {\n ticket_hash : Ticket_hash.t;\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n paid_storage_size_diff : Z.t;\n }\n\ntype successful_origination_result = {\n lazy_storage_diff : Lazy_storage.diffs option;\n balance_updates : Receipt.balance_updates;\n originated_contracts : Contract_hash.t list;\n consumed_gas : Gas.Arith.fp;\n storage_size : Z.t;\n paid_storage_size_diff : Z.t;\n}\n\n(** Result of applying an internal operation. *)\ntype _ successful_internal_operation_result =\n | ITransaction_result :\n successful_transaction_result\n -> Kind.transaction successful_internal_operation_result\n | IOrigination_result :\n successful_origination_result\n -> Kind.origination successful_internal_operation_result\n | IDelegation_result : {\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.delegation successful_internal_operation_result\n | IEvent_result : {\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.event successful_internal_operation_result\n\ntype packed_successful_internal_operation_result =\n | Successful_internal_operation_result :\n 'kind successful_internal_operation_result\n -> packed_successful_internal_operation_result\n\ntype 'kind internal_operation_result =\n ( 'kind,\n 'kind Kind.manager,\n 'kind successful_internal_operation_result )\n operation_result\n\ntype packed_internal_operation_result =\n | Internal_operation_result :\n 'kind internal_operation * 'kind internal_operation_result\n -> packed_internal_operation_result\n\nlet pack_internal_operation_result (type kind)\n (internal_op : kind Script_typed_ir.internal_operation)\n (manager_op : kind internal_operation_result) =\n let internal_op = internal_operation internal_op in\n Internal_operation_result (internal_op, manager_op)\n\ntype 'kind iselect =\n packed_internal_operation_result ->\n ('kind internal_operation * 'kind internal_operation_result) option\n\nmodule Internal_operation = struct\n open Data_encoding\n\n type 'kind case =\n | MCase : {\n tag : int;\n name : string;\n encoding : 'a Data_encoding.t;\n iselect : 'kind iselect;\n select :\n packed_internal_operation_contents ->\n 'kind internal_operation_contents option;\n proj : 'kind internal_operation_contents -> 'a;\n inj : 'a -> 'kind internal_operation_contents;\n }\n -> 'kind case\n\n let transaction_contract_variant_cases =\n union\n [\n case\n ~title:\"To_contract\"\n (Tag 0)\n (obj9\n (opt \"storage\" Script.expr_encoding)\n (dft \"balance_updates\" Receipt.balance_updates_encoding [])\n (dft \"ticket_receipt\" Ticket_receipt.encoding [])\n (dft \"originated_contracts\" (list Contract.originated_encoding) [])\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (dft \"storage_size\" z Z.zero)\n (dft \"paid_storage_size_diff\" z Z.zero)\n (dft \"allocated_destination_contract\" bool false)\n (opt \"lazy_storage_diff\" Lazy_storage.encoding))\n (function\n | Transaction_to_contract_result\n {\n storage;\n lazy_storage_diff;\n balance_updates;\n ticket_receipt;\n originated_contracts;\n consumed_gas;\n storage_size;\n paid_storage_size_diff;\n allocated_destination_contract;\n } ->\n Some\n ( storage,\n balance_updates,\n ticket_receipt,\n originated_contracts,\n consumed_gas,\n storage_size,\n paid_storage_size_diff,\n allocated_destination_contract,\n lazy_storage_diff )\n | _ -> None)\n (fun ( storage,\n balance_updates,\n ticket_receipt,\n originated_contracts,\n consumed_gas,\n storage_size,\n paid_storage_size_diff,\n allocated_destination_contract,\n lazy_storage_diff ) ->\n Transaction_to_contract_result\n {\n storage;\n lazy_storage_diff;\n balance_updates;\n ticket_receipt;\n originated_contracts;\n consumed_gas;\n storage_size;\n paid_storage_size_diff;\n allocated_destination_contract;\n });\n case\n ~title:\"To_tx_rollup\"\n (Tag 1)\n (obj4\n (dft \"balance_updates\" Receipt.balance_updates_encoding [])\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (req \"ticket_hash\" Ticket_hash.encoding)\n (req \"paid_storage_size_diff\" n))\n (function\n | Transaction_to_tx_rollup_result\n {\n balance_updates;\n consumed_gas;\n ticket_hash;\n paid_storage_size_diff;\n } ->\n Some\n ( balance_updates,\n consumed_gas,\n ticket_hash,\n paid_storage_size_diff )\n | _ -> None)\n (fun ( balance_updates,\n consumed_gas,\n ticket_hash,\n paid_storage_size_diff ) ->\n Transaction_to_tx_rollup_result\n {\n balance_updates;\n consumed_gas;\n ticket_hash;\n paid_storage_size_diff;\n });\n case\n ~title:\"To_smart_rollup\"\n (Tag 2)\n (obj2\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (req \"ticket_receipt\" Ticket_receipt.encoding))\n (function\n | Transaction_to_sc_rollup_result {consumed_gas; ticket_receipt} ->\n Some (consumed_gas, ticket_receipt)\n | _ -> None)\n (function\n | consumed_gas, ticket_receipt ->\n Transaction_to_sc_rollup_result {consumed_gas; ticket_receipt});\n ]\n\n let transaction_case =\n MCase\n {\n (* This value should be changed with care: maybe receipts are read by\n external tools such as indexers. *)\n tag = 1;\n name = \"transaction\";\n encoding =\n obj3\n (req \"amount\" Tez.encoding)\n (req \"destination\" Destination.encoding)\n (opt\n \"parameters\"\n (obj2\n (req \"entrypoint\" Entrypoint.smart_encoding)\n (req \"value\" Script.lazy_expr_encoding)));\n iselect : Kind.transaction iselect =\n (function\n | Internal_operation_result\n (({operation = Transaction _; _} as op), res) ->\n Some (op, res)\n | _ -> None);\n select =\n (function\n | Internal_operation_contents (Transaction _ as op) -> Some op\n | _ -> None);\n proj =\n (function\n | Transaction {amount; destination; parameters; entrypoint} ->\n let parameters =\n if\n Script_repr.is_unit_parameter parameters\n && Entrypoint.is_default entrypoint\n then None\n else Some (entrypoint, parameters)\n in\n (amount, destination, parameters));\n inj =\n (fun (amount, destination, parameters) ->\n let entrypoint, parameters =\n match parameters with\n | None -> (Entrypoint.default, Script.unit_parameter)\n | Some (entrypoint, value) -> (entrypoint, value)\n in\n Transaction {amount; destination; parameters; entrypoint});\n }\n\n let origination_case =\n MCase\n {\n (* This value should be changed with care: maybe receipts are read by\n external tools such as indexers. *)\n tag = 2;\n name = \"origination\";\n encoding =\n obj3\n (req \"balance\" Tez.encoding)\n (opt \"delegate\" Signature.Public_key_hash.encoding)\n (req \"script\" Script.encoding);\n iselect : Kind.origination iselect =\n (function\n | Internal_operation_result\n (({operation = Origination _; _} as op), res) ->\n Some (op, res)\n | _ -> None);\n select =\n (function\n | Internal_operation_contents (Origination _ as op) -> Some op\n | _ -> None);\n proj =\n (function\n | Origination {credit; delegate; script} -> (credit, delegate, script));\n inj =\n (fun (credit, delegate, script) ->\n Origination {credit; delegate; script});\n }\n\n let delegation_case =\n MCase\n {\n (* This value should be changed with care: maybe receipts are read by\n external tools such as indexers. *)\n tag = 3;\n name = \"delegation\";\n encoding = obj1 (opt \"delegate\" Signature.Public_key_hash.encoding);\n iselect : Kind.delegation iselect =\n (function\n | Internal_operation_result\n (({operation = Delegation _; _} as op), res) ->\n Some (op, res)\n | _ -> None);\n select =\n (function\n | Internal_operation_contents (Delegation _ as op) -> Some op\n | _ -> None);\n proj = (function Delegation key -> key);\n inj = (fun key -> Delegation key);\n }\n\n let event_case =\n MCase\n {\n (* This value should be changed with care: maybe receipts are read by\n external tools such as indexers. *)\n tag = 4;\n name = \"event\";\n encoding =\n obj3\n (req \"type\" Script.expr_encoding)\n (opt \"tag\" Entrypoint.smart_encoding)\n (opt \"payload\" Script.expr_encoding);\n iselect : Kind.event iselect =\n (function\n | Internal_operation_result (({operation = Event _; _} as op), res) ->\n Some (op, res)\n | _ -> None);\n select =\n (function\n | Internal_operation_contents (Event _ as op) -> Some op | _ -> None);\n proj =\n (function\n | Event {ty; tag; payload} ->\n let tag = if Entrypoint.is_default tag then None else Some tag in\n let payload =\n if Script_repr.is_unit payload then None else Some payload\n in\n (ty, tag, payload));\n inj =\n (fun (ty, tag, payload) ->\n let tag = Option.value ~default:Entrypoint.default tag in\n let payload = Option.value ~default:Script_repr.unit payload in\n Event {ty; tag; payload});\n }\n\n let case tag name args proj inj =\n case\n tag\n ~title:(String.capitalize_ascii name)\n (merge_objs (obj1 (req \"kind\" (constant name))) args)\n (fun x -> match proj x with None -> None | Some x -> Some ((), x))\n (fun ((), x) -> inj x)\n\n let encoding =\n let make (MCase {tag; name; encoding; iselect = _; select; proj; inj}) =\n case\n (Tag tag)\n name\n encoding\n (fun o -> match select o with None -> None | Some o -> Some (proj o))\n (fun x -> Internal_operation_contents (inj x))\n in\n union\n ~tag_size:`Uint8\n [\n make transaction_case;\n make origination_case;\n make delegation_case;\n make event_case;\n ]\nend\n\nlet internal_operation_encoding : packed_internal_operation Data_encoding.t =\n def \"apply_internal_results.alpha.operation_result\"\n @@ conv\n (fun (Internal_operation {source; operation; nonce}) ->\n ((source, nonce), Internal_operation_contents operation))\n (fun ((source, nonce), Internal_operation_contents operation) ->\n Internal_operation {source; operation; nonce})\n (merge_objs\n (obj2 (req \"source\" Destination.encoding) (req \"nonce\" uint16))\n Internal_operation.encoding)\n\nmodule Internal_operation_result = struct\n type 'kind case =\n | MCase : {\n op_case : 'kind Internal_operation.case;\n encoding : 'a Data_encoding.t;\n kind : 'kind Kind.manager;\n select :\n packed_successful_internal_operation_result ->\n 'kind successful_internal_operation_result option;\n proj : 'kind successful_internal_operation_result -> 'a;\n inj : 'a -> 'kind successful_internal_operation_result;\n t : 'kind internal_operation_result Data_encoding.t;\n }\n -> 'kind case\n\n let make ~op_case ~encoding ~kind ~select ~proj ~inj =\n let (Internal_operation.MCase {name; _}) = op_case in\n let t =\n def (Format.asprintf \"operation.alpha.internal_operation_result.%s\" name)\n @@ union\n ~tag_size:`Uint8\n [\n case\n (Tag 0)\n ~title:\"Applied\"\n (merge_objs (obj1 (req \"status\" (constant \"applied\"))) encoding)\n (fun o ->\n match o with\n | Skipped _ | Failed _ | Backtracked _ -> None\n | Applied o -> (\n match select (Successful_internal_operation_result o) with\n | None -> None\n | Some o -> Some ((), proj o)))\n (fun ((), x) -> Applied (inj x));\n case\n (Tag 1)\n ~title:\"Failed\"\n (obj2\n (req \"status\" (constant \"failed\"))\n (req \"errors\" trace_encoding))\n (function Failed (_, errs) -> Some ((), errs) | _ -> None)\n (fun ((), errs) -> Failed (kind, errs));\n case\n (Tag 2)\n ~title:\"Skipped\"\n (obj1 (req \"status\" (constant \"skipped\")))\n (function Skipped _ -> Some () | _ -> None)\n (fun () -> Skipped kind);\n case\n (Tag 3)\n ~title:\"Backtracked\"\n (merge_objs\n (obj2\n (req \"status\" (constant \"backtracked\"))\n (opt \"errors\" trace_encoding))\n encoding)\n (fun o ->\n match o with\n | Skipped _ | Failed _ | Applied _ -> None\n | Backtracked (o, errs) -> (\n match select (Successful_internal_operation_result o) with\n | None -> None\n | Some o -> Some (((), errs), proj o)))\n (fun (((), errs), x) -> Backtracked (inj x, errs));\n ]\n in\n MCase {op_case; encoding; kind; select; proj; inj; t}\n\n let transaction_case =\n make\n ~op_case:Internal_operation.transaction_case\n ~encoding:Internal_operation.transaction_contract_variant_cases\n ~select:(function\n | Successful_internal_operation_result (ITransaction_result _ as op) ->\n Some op\n | _ -> None)\n ~kind:Kind.Transaction_manager_kind\n ~proj:(function ITransaction_result x -> x)\n ~inj:(fun x -> ITransaction_result x)\n\n let origination_case =\n make\n ~op_case:Internal_operation.origination_case\n ~encoding:\n (obj6\n (dft \"balance_updates\" Receipt.balance_updates_encoding [])\n (dft \"originated_contracts\" (list Contract.originated_encoding) [])\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (dft \"storage_size\" z Z.zero)\n (dft \"paid_storage_size_diff\" z Z.zero)\n (opt \"lazy_storage_diff\" Lazy_storage.encoding))\n ~select:(function\n | Successful_internal_operation_result (IOrigination_result _ as op) ->\n Some op\n | _ -> None)\n ~proj:(function\n | IOrigination_result\n {\n lazy_storage_diff;\n balance_updates;\n originated_contracts;\n consumed_gas;\n storage_size;\n paid_storage_size_diff;\n } ->\n (* There used to be a [legacy_lazy_storage_diff] returned as the\n first component of the tuple below, and the non-legacy one\n returned as the last component. The legacy one has been removed,\n but it was chosen to keep the non-legacy one at its position,\n hence the order difference with regards to the record above. *)\n ( balance_updates,\n originated_contracts,\n consumed_gas,\n storage_size,\n paid_storage_size_diff,\n lazy_storage_diff ))\n ~kind:Kind.Origination_manager_kind\n ~inj:\n (fun ( balance_updates,\n originated_contracts,\n consumed_gas,\n storage_size,\n paid_storage_size_diff,\n lazy_storage_diff ) ->\n IOrigination_result\n {\n lazy_storage_diff;\n balance_updates;\n originated_contracts;\n consumed_gas;\n storage_size;\n paid_storage_size_diff;\n })\n\n let delegation_case =\n make\n ~op_case:Internal_operation.delegation_case\n ~encoding:\n Data_encoding.(\n obj1 (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero))\n ~select:(function\n | Successful_internal_operation_result (IDelegation_result _ as op) ->\n Some op\n | _ -> None)\n ~kind:Kind.Delegation_manager_kind\n ~proj:(function IDelegation_result {consumed_gas} -> consumed_gas)\n ~inj:(fun consumed_gas -> IDelegation_result {consumed_gas})\n\n let event_case =\n make\n ~op_case:Internal_operation.event_case\n ~encoding:\n Data_encoding.(\n obj1 (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero))\n ~select:(function\n | Successful_internal_operation_result (IEvent_result _ as op) ->\n Some op\n | _ -> None)\n ~kind:Kind.Event_manager_kind\n ~proj:(function IEvent_result {consumed_gas} -> consumed_gas)\n ~inj:(fun consumed_gas -> IEvent_result {consumed_gas})\nend\n\nlet internal_operation_result_encoding :\n packed_internal_operation_result Data_encoding.t =\n let make (type kind)\n (Internal_operation_result.MCase res_case :\n kind Internal_operation_result.case)\n (Internal_operation.MCase ires_case : kind Internal_operation.case) =\n let (Internal_operation.MCase op_case) = res_case.op_case in\n case\n (Tag op_case.tag)\n ~title:op_case.name\n (merge_objs\n (obj3\n (req \"kind\" (constant op_case.name))\n (req \"source\" Destination.encoding)\n (req \"nonce\" uint16))\n (merge_objs ires_case.encoding (obj1 (req \"result\" res_case.t))))\n (fun op ->\n match ires_case.iselect op with\n | Some (op, res) ->\n Some (((), op.source, op.nonce), (ires_case.proj op.operation, res))\n | None -> None)\n (fun (((), source, nonce), (op, res)) ->\n let op = {source; operation = ires_case.inj op; nonce} in\n Internal_operation_result (op, res))\n in\n def \"apply_internal_results.alpha.operation_result\"\n @@ union\n [\n make\n Internal_operation_result.transaction_case\n Internal_operation.transaction_case;\n make\n Internal_operation_result.origination_case\n Internal_operation.origination_case;\n make\n Internal_operation_result.delegation_case\n Internal_operation.delegation_case;\n make Internal_operation_result.event_case Internal_operation.event_case;\n ]\n" ;
} ;
{ name = "Apply_results" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Types representing results of applying an operation.\n\n These are used internally by [Apply], and can be used for experimenting\n with protocol updates, by clients to print out a summary of the\n operation at pre-injection simulation and at confirmation time,\n and by block explorers.\n *)\n\nopen Alpha_context\nopen Apply_operation_result\nopen Apply_internal_results\n\n(** Result of applying a {!Operation.t}. Follows the same structure. *)\ntype 'kind operation_metadata = {contents : 'kind contents_result_list}\n\nand packed_operation_metadata =\n | Operation_metadata : 'kind operation_metadata -> packed_operation_metadata\n | No_operation_metadata : packed_operation_metadata\n\n(** Result of applying a {!Operation.contents_list}. Follows the same structure. *)\nand 'kind contents_result_list =\n | Single_result : 'kind contents_result -> 'kind contents_result_list\n | Cons_result :\n 'kind Kind.manager contents_result\n * 'rest Kind.manager contents_result_list\n -> ('kind * 'rest) Kind.manager contents_result_list\n\nand packed_contents_result_list =\n | Contents_result_list :\n 'kind contents_result_list\n -> packed_contents_result_list\n\n(** Result of applying an {!Operation.contents}. Follows the same structure. *)\nand 'kind contents_result =\n | Preendorsement_result : {\n balance_updates : Receipt.balance_updates;\n delegate : Signature.public_key_hash;\n consensus_key : Signature.public_key_hash;\n preendorsement_power : int;\n }\n -> Kind.preendorsement contents_result\n | Endorsement_result : {\n balance_updates : Receipt.balance_updates;\n delegate : Signature.public_key_hash;\n consensus_key : Signature.public_key_hash;\n endorsement_power : int;\n }\n -> Kind.endorsement contents_result\n | Dal_attestation_result : {\n delegate : Signature.Public_key_hash.t;\n }\n -> Kind.dal_attestation contents_result\n | Seed_nonce_revelation_result :\n Receipt.balance_updates\n -> Kind.seed_nonce_revelation contents_result\n | Vdf_revelation_result :\n Receipt.balance_updates\n -> Kind.vdf_revelation contents_result\n | Double_endorsement_evidence_result :\n Receipt.balance_updates\n -> Kind.double_endorsement_evidence contents_result\n | Double_preendorsement_evidence_result :\n Receipt.balance_updates\n -> Kind.double_preendorsement_evidence contents_result\n | Double_baking_evidence_result :\n Receipt.balance_updates\n -> Kind.double_baking_evidence contents_result\n | Activate_account_result :\n Receipt.balance_updates\n -> Kind.activate_account contents_result\n | Proposals_result : Kind.proposals contents_result\n | Ballot_result : Kind.ballot contents_result\n | Drain_delegate_result : {\n balance_updates : Receipt.balance_updates;\n allocated_destination_contract : bool;\n }\n -> Kind.drain_delegate contents_result\n | Manager_operation_result : {\n balance_updates : Receipt.balance_updates;\n operation_result : 'kind manager_operation_result;\n internal_operation_results : packed_internal_operation_result list;\n }\n -> 'kind Kind.manager contents_result\n\nand packed_contents_result =\n | Contents_result : 'kind contents_result -> packed_contents_result\n\nand 'kind manager_operation_result =\n ( 'kind,\n 'kind Kind.manager,\n 'kind successful_manager_operation_result )\n operation_result\n\n(** Result of applying a transaction. *)\nand successful_transaction_result =\n Apply_internal_results.successful_transaction_result\n\n(** Result of applying an origination. *)\nand successful_origination_result =\n Apply_internal_results.successful_origination_result\n\n(** Result of applying an external {!manager_operation_content}. *)\nand _ successful_manager_operation_result =\n | Reveal_result : {\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.reveal successful_manager_operation_result\n | Transaction_result :\n successful_transaction_result\n -> Kind.transaction successful_manager_operation_result\n | Origination_result :\n successful_origination_result\n -> Kind.origination successful_manager_operation_result\n | Delegation_result : {\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.delegation successful_manager_operation_result\n | Register_global_constant_result : {\n (* The manager submitting the operation must pay\n the cost of storage for the registered value.\n We include the balance update here. *)\n balance_updates : Receipt.balance_updates;\n (* Gas consumed while validating and storing the registered\n value. *)\n consumed_gas : Gas.Arith.fp;\n (* The size of the registered value in bytes.\n Currently, this is simply the number of bytes in the binary\n serialization of the Micheline value. *)\n size_of_constant : Z.t;\n (* The address of the newly registered value, being\n the hash of its binary serialization. This could be\n calulated on demand but we include it here in the\n receipt for flexibility in the future. *)\n global_address : Script_expr_hash.t;\n }\n -> Kind.register_global_constant successful_manager_operation_result\n | Set_deposits_limit_result : {\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.set_deposits_limit successful_manager_operation_result\n | Increase_paid_storage_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.increase_paid_storage successful_manager_operation_result\n | Update_consensus_key_result : {\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.update_consensus_key successful_manager_operation_result\n | Tx_rollup_origination_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n originated_tx_rollup : Tx_rollup.t;\n }\n -> Kind.tx_rollup_origination successful_manager_operation_result\n | Tx_rollup_submit_batch_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n paid_storage_size_diff : Z.t;\n }\n -> Kind.tx_rollup_submit_batch successful_manager_operation_result\n | Tx_rollup_commit_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.tx_rollup_commit successful_manager_operation_result\n | Tx_rollup_return_bond_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.tx_rollup_return_bond successful_manager_operation_result\n | Tx_rollup_finalize_commitment_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n level : Tx_rollup_level.t;\n }\n -> Kind.tx_rollup_finalize_commitment successful_manager_operation_result\n | Tx_rollup_remove_commitment_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n level : Tx_rollup_level.t;\n }\n -> Kind.tx_rollup_remove_commitment successful_manager_operation_result\n | Tx_rollup_rejection_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.tx_rollup_rejection successful_manager_operation_result\n | Tx_rollup_dispatch_tickets_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n paid_storage_size_diff : Z.t;\n }\n -> Kind.tx_rollup_dispatch_tickets successful_manager_operation_result\n | Transfer_ticket_result : {\n balance_updates : Receipt.balance_updates;\n ticket_receipt : Ticket_receipt.t;\n consumed_gas : Gas.Arith.fp;\n paid_storage_size_diff : Z.t;\n }\n -> Kind.transfer_ticket successful_manager_operation_result\n | Dal_publish_slot_header_result : {\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.dal_publish_slot_header successful_manager_operation_result\n | Sc_rollup_originate_result : {\n balance_updates : Receipt.balance_updates;\n address : Sc_rollup.Address.t;\n genesis_commitment_hash : Sc_rollup.Commitment.Hash.t;\n consumed_gas : Gas.Arith.fp;\n size : Z.t;\n }\n -> Kind.sc_rollup_originate successful_manager_operation_result\n | Sc_rollup_add_messages_result : {\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.sc_rollup_add_messages successful_manager_operation_result\n | Sc_rollup_cement_result : {\n consumed_gas : Gas.Arith.fp;\n inbox_level : Raw_level.t;\n }\n -> Kind.sc_rollup_cement successful_manager_operation_result\n | Sc_rollup_publish_result : {\n consumed_gas : Gas.Arith.fp;\n staked_hash : Sc_rollup.Commitment.Hash.t;\n published_at_level : Raw_level.t;\n balance_updates : Receipt.balance_updates;\n }\n -> Kind.sc_rollup_publish successful_manager_operation_result\n | Sc_rollup_refute_result : {\n consumed_gas : Gas.Arith.fp;\n game_status : Sc_rollup.Game.status;\n balance_updates : Receipt.balance_updates;\n }\n -> Kind.sc_rollup_refute successful_manager_operation_result\n | Sc_rollup_timeout_result : {\n consumed_gas : Gas.Arith.fp;\n game_status : Sc_rollup.Game.status;\n balance_updates : Receipt.balance_updates;\n }\n -> Kind.sc_rollup_timeout successful_manager_operation_result\n | Sc_rollup_execute_outbox_message_result : {\n balance_updates : Receipt.balance_updates;\n ticket_receipt : Ticket_receipt.t;\n consumed_gas : Gas.Arith.fp;\n paid_storage_size_diff : Z.t;\n }\n -> Kind.sc_rollup_execute_outbox_message\n successful_manager_operation_result\n | Sc_rollup_recover_bond_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.sc_rollup_recover_bond successful_manager_operation_result\n | Zk_rollup_origination_result : {\n balance_updates : Receipt.balance_updates;\n originated_zk_rollup : Zk_rollup.t;\n consumed_gas : Gas.Arith.fp;\n (* Number of bytes allocated by the ZKRU origination.\n Used to burn storage fees. *)\n storage_size : Z.t;\n }\n -> Kind.zk_rollup_origination successful_manager_operation_result\n | Zk_rollup_publish_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n paid_storage_size_diff : Z.t;\n }\n -> Kind.zk_rollup_publish successful_manager_operation_result\n | Zk_rollup_update_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n paid_storage_size_diff : Z.t;\n }\n -> Kind.zk_rollup_update successful_manager_operation_result\n\nand packed_successful_manager_operation_result =\n | Successful_manager_result :\n 'kind successful_manager_operation_result\n -> packed_successful_manager_operation_result\n\nval pack_migration_operation_results :\n Migration.origination_result list ->\n packed_successful_manager_operation_result list\n\n(** Serializer for {!packed_operation_result}. *)\nval operation_metadata_encoding : packed_operation_metadata Data_encoding.t\n\nval operation_data_and_metadata_encoding :\n (Operation.packed_protocol_data * packed_operation_metadata) Data_encoding.t\n\ntype 'kind contents_and_result_list =\n | Single_and_result :\n 'kind Alpha_context.contents * 'kind contents_result\n -> 'kind contents_and_result_list\n | Cons_and_result :\n 'kind Kind.manager Alpha_context.contents\n * 'kind Kind.manager contents_result\n * 'rest Kind.manager contents_and_result_list\n -> ('kind * 'rest) Kind.manager contents_and_result_list\n\ntype packed_contents_and_result_list =\n | Contents_and_result_list :\n 'kind contents_and_result_list\n -> packed_contents_and_result_list\n\nval contents_and_result_list_encoding :\n packed_contents_and_result_list Data_encoding.t\n\nval pack_contents_list :\n 'kind contents_list ->\n 'kind contents_result_list ->\n 'kind contents_and_result_list\n\nval unpack_contents_list :\n 'kind contents_and_result_list ->\n 'kind contents_list * 'kind contents_result_list\n\nval to_list : packed_contents_result_list -> packed_contents_result list\n\ntype ('a, 'b) eq = Eq : ('a, 'a) eq\n\nval kind_equal_list :\n 'kind contents_list ->\n 'kind2 contents_result_list ->\n ('kind, 'kind2) eq option\n\ntype block_metadata = {\n proposer : Consensus_key.t;\n baker : Consensus_key.t;\n level_info : Level.t;\n voting_period_info : Voting_period.info;\n nonce_hash : Nonce_hash.t option;\n consumed_gas : Gas.Arith.fp;\n deactivated : Signature.Public_key_hash.t list;\n balance_updates : Receipt.balance_updates;\n liquidity_baking_toggle_ema : Liquidity_baking.Toggle_EMA.t;\n implicit_operations_results : packed_successful_manager_operation_result list;\n dal_attestation : Dal.Attestation.t option;\n}\n\nval block_metadata_encoding : block_metadata Data_encoding.encoding\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\nopen Data_encoding\nopen Apply_operation_result\nopen Apply_internal_results\n\ntype successful_transaction_result =\n Apply_internal_results.successful_transaction_result\n\ntype successful_origination_result =\n Apply_internal_results.successful_origination_result\n\ntype _ successful_manager_operation_result =\n | Reveal_result : {\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.reveal successful_manager_operation_result\n | Transaction_result :\n successful_transaction_result\n -> Kind.transaction successful_manager_operation_result\n | Origination_result :\n successful_origination_result\n -> Kind.origination successful_manager_operation_result\n | Delegation_result : {\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.delegation successful_manager_operation_result\n | Register_global_constant_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n size_of_constant : Z.t;\n global_address : Script_expr_hash.t;\n }\n -> Kind.register_global_constant successful_manager_operation_result\n | Set_deposits_limit_result : {\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.set_deposits_limit successful_manager_operation_result\n | Increase_paid_storage_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.increase_paid_storage successful_manager_operation_result\n | Update_consensus_key_result : {\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.update_consensus_key successful_manager_operation_result\n | Tx_rollup_origination_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n originated_tx_rollup : Tx_rollup.t;\n }\n -> Kind.tx_rollup_origination successful_manager_operation_result\n | Tx_rollup_submit_batch_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n paid_storage_size_diff : Z.t;\n }\n -> Kind.tx_rollup_submit_batch successful_manager_operation_result\n | Tx_rollup_commit_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.tx_rollup_commit successful_manager_operation_result\n | Tx_rollup_return_bond_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.tx_rollup_return_bond successful_manager_operation_result\n | Tx_rollup_finalize_commitment_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n level : Tx_rollup_level.t;\n }\n -> Kind.tx_rollup_finalize_commitment successful_manager_operation_result\n | Tx_rollup_remove_commitment_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n level : Tx_rollup_level.t;\n }\n -> Kind.tx_rollup_remove_commitment successful_manager_operation_result\n | Tx_rollup_rejection_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.tx_rollup_rejection successful_manager_operation_result\n | Tx_rollup_dispatch_tickets_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n paid_storage_size_diff : Z.t;\n }\n -> Kind.tx_rollup_dispatch_tickets successful_manager_operation_result\n | Transfer_ticket_result : {\n balance_updates : Receipt.balance_updates;\n ticket_receipt : Ticket_receipt.t;\n consumed_gas : Gas.Arith.fp;\n paid_storage_size_diff : Z.t;\n }\n -> Kind.transfer_ticket successful_manager_operation_result\n | Dal_publish_slot_header_result : {\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.dal_publish_slot_header successful_manager_operation_result\n | Sc_rollup_originate_result : {\n balance_updates : Receipt.balance_updates;\n address : Sc_rollup.Address.t;\n genesis_commitment_hash : Sc_rollup.Commitment.Hash.t;\n consumed_gas : Gas.Arith.fp;\n size : Z.t;\n }\n -> Kind.sc_rollup_originate successful_manager_operation_result\n | Sc_rollup_add_messages_result : {\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.sc_rollup_add_messages successful_manager_operation_result\n | Sc_rollup_cement_result : {\n consumed_gas : Gas.Arith.fp;\n inbox_level : Raw_level.t;\n }\n -> Kind.sc_rollup_cement successful_manager_operation_result\n | Sc_rollup_publish_result : {\n consumed_gas : Gas.Arith.fp;\n staked_hash : Sc_rollup.Commitment.Hash.t;\n published_at_level : Raw_level.t;\n balance_updates : Receipt.balance_updates;\n }\n -> Kind.sc_rollup_publish successful_manager_operation_result\n | Sc_rollup_refute_result : {\n consumed_gas : Gas.Arith.fp;\n game_status : Sc_rollup.Game.status;\n balance_updates : Receipt.balance_updates;\n }\n -> Kind.sc_rollup_refute successful_manager_operation_result\n | Sc_rollup_timeout_result : {\n consumed_gas : Gas.Arith.fp;\n game_status : Sc_rollup.Game.status;\n balance_updates : Receipt.balance_updates;\n }\n -> Kind.sc_rollup_timeout successful_manager_operation_result\n | Sc_rollup_execute_outbox_message_result : {\n balance_updates : Receipt.balance_updates;\n ticket_receipt : Ticket_receipt.t;\n consumed_gas : Gas.Arith.fp;\n paid_storage_size_diff : Z.t;\n }\n -> Kind.sc_rollup_execute_outbox_message\n successful_manager_operation_result\n | Sc_rollup_recover_bond_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n }\n -> Kind.sc_rollup_recover_bond successful_manager_operation_result\n | Zk_rollup_origination_result : {\n balance_updates : Receipt.balance_updates;\n originated_zk_rollup : Zk_rollup.t;\n consumed_gas : Gas.Arith.fp;\n storage_size : Z.t;\n }\n -> Kind.zk_rollup_origination successful_manager_operation_result\n | Zk_rollup_publish_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n paid_storage_size_diff : Z.t;\n }\n -> Kind.zk_rollup_publish successful_manager_operation_result\n | Zk_rollup_update_result : {\n balance_updates : Receipt.balance_updates;\n consumed_gas : Gas.Arith.fp;\n paid_storage_size_diff : Z.t;\n }\n -> Kind.zk_rollup_update successful_manager_operation_result\n\nlet migration_origination_result_to_successful_manager_operation_result\n ({\n balance_updates;\n originated_contracts;\n storage_size;\n paid_storage_size_diff;\n } :\n Migration.origination_result) =\n Origination_result\n {\n lazy_storage_diff = None;\n balance_updates;\n originated_contracts;\n consumed_gas = Gas.Arith.zero;\n storage_size;\n paid_storage_size_diff;\n }\n\ntype packed_successful_manager_operation_result =\n | Successful_manager_result :\n 'kind successful_manager_operation_result\n -> packed_successful_manager_operation_result\n\nlet pack_migration_operation_results results =\n List.map\n (fun el ->\n Successful_manager_result\n (migration_origination_result_to_successful_manager_operation_result el))\n results\n\ntype 'kind manager_operation_result =\n ( 'kind,\n 'kind Kind.manager,\n 'kind successful_manager_operation_result )\n operation_result\n\nmodule Manager_result = struct\n type 'kind case =\n | MCase : {\n op_case : 'kind Operation.Encoding.Manager_operations.case;\n encoding : 'a Data_encoding.t;\n kind : 'kind Kind.manager;\n select :\n packed_successful_manager_operation_result ->\n 'kind successful_manager_operation_result option;\n proj : 'kind successful_manager_operation_result -> 'a;\n inj : 'a -> 'kind successful_manager_operation_result;\n t : 'kind manager_operation_result Data_encoding.t;\n }\n -> 'kind case\n\n let make ~op_case ~encoding ~kind ~select ~proj ~inj =\n let (Operation.Encoding.Manager_operations.MCase {name; _}) = op_case in\n let t =\n def (Format.asprintf \"operation.alpha.operation_result.%s\" name)\n @@ union\n ~tag_size:`Uint8\n [\n case\n (Tag 0)\n ~title:\"Applied\"\n (merge_objs (obj1 (req \"status\" (constant \"applied\"))) encoding)\n (fun o ->\n match o with\n | Skipped _ | Failed _ | Backtracked _ -> None\n | Applied o -> (\n match select (Successful_manager_result o) with\n | None -> None\n | Some o -> Some ((), proj o)))\n (fun ((), x) -> Applied (inj x));\n case\n (Tag 1)\n ~title:\"Failed\"\n (obj2\n (req \"status\" (constant \"failed\"))\n (req \"errors\" trace_encoding))\n (function Failed (_, errs) -> Some ((), errs) | _ -> None)\n (fun ((), errs) -> Failed (kind, errs));\n case\n (Tag 2)\n ~title:\"Skipped\"\n (obj1 (req \"status\" (constant \"skipped\")))\n (function Skipped _ -> Some () | _ -> None)\n (fun () -> Skipped kind);\n case\n (Tag 3)\n ~title:\"Backtracked\"\n (merge_objs\n (obj2\n (req \"status\" (constant \"backtracked\"))\n (opt \"errors\" trace_encoding))\n encoding)\n (fun o ->\n match o with\n | Skipped _ | Failed _ | Applied _ -> None\n | Backtracked (o, errs) -> (\n match select (Successful_manager_result o) with\n | None -> None\n | Some o -> Some (((), errs), proj o)))\n (fun (((), errs), x) -> Backtracked (inj x, errs));\n ]\n in\n MCase {op_case; encoding; kind; select; proj; inj; t}\n\n let reveal_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.reveal_case\n ~encoding:\n Data_encoding.(\n obj1 (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero))\n ~select:(function\n | Successful_manager_result (Reveal_result _ as op) -> Some op\n | _ -> None)\n ~kind:Kind.Reveal_manager_kind\n ~proj:(function Reveal_result {consumed_gas} -> consumed_gas)\n ~inj:(fun consumed_gas -> Reveal_result {consumed_gas})\n\n let transaction_contract_variant_cases =\n union\n [\n case\n ~title:\"To_contract\"\n (Tag 0)\n (obj9\n (opt \"storage\" Script.expr_encoding)\n (dft \"balance_updates\" Receipt.balance_updates_encoding [])\n (dft \"ticket_updates\" Ticket_receipt.encoding [])\n (dft \"originated_contracts\" (list Contract.originated_encoding) [])\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (dft \"storage_size\" z Z.zero)\n (dft \"paid_storage_size_diff\" z Z.zero)\n (dft \"allocated_destination_contract\" bool false)\n (opt \"lazy_storage_diff\" Lazy_storage.encoding))\n (function\n | Transaction_to_contract_result\n {\n storage;\n lazy_storage_diff;\n balance_updates;\n ticket_receipt;\n originated_contracts;\n consumed_gas;\n storage_size;\n paid_storage_size_diff;\n allocated_destination_contract;\n } ->\n Some\n ( storage,\n balance_updates,\n ticket_receipt,\n originated_contracts,\n consumed_gas,\n storage_size,\n paid_storage_size_diff,\n allocated_destination_contract,\n lazy_storage_diff )\n | _ -> None)\n (fun ( storage,\n balance_updates,\n ticket_receipt,\n originated_contracts,\n consumed_gas,\n storage_size,\n paid_storage_size_diff,\n allocated_destination_contract,\n lazy_storage_diff ) ->\n Transaction_to_contract_result\n {\n storage;\n lazy_storage_diff;\n balance_updates;\n ticket_receipt;\n originated_contracts;\n consumed_gas;\n storage_size;\n paid_storage_size_diff;\n allocated_destination_contract;\n });\n case\n ~title:\"To_tx_rollup\"\n (Tag 1)\n (obj4\n (dft \"balance_updates\" Receipt.balance_updates_encoding [])\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (req \"ticket_hash\" Ticket_hash.encoding)\n (req \"paid_storage_size_diff\" n))\n (function\n | Transaction_to_tx_rollup_result\n {\n balance_updates;\n consumed_gas;\n ticket_hash;\n paid_storage_size_diff;\n } ->\n Some\n ( balance_updates,\n consumed_gas,\n ticket_hash,\n paid_storage_size_diff )\n | _ -> None)\n (fun ( balance_updates,\n consumed_gas,\n ticket_hash,\n paid_storage_size_diff ) ->\n Transaction_to_tx_rollup_result\n {\n balance_updates;\n consumed_gas;\n ticket_hash;\n paid_storage_size_diff;\n });\n case\n ~title:\"To_smart_rollup\"\n (Tag 2)\n (obj2\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (req \"ticket_updates\" Ticket_receipt.encoding))\n (function\n | Transaction_to_sc_rollup_result {consumed_gas; ticket_receipt} ->\n Some (consumed_gas, ticket_receipt)\n | _ -> None)\n (function\n | consumed_gas, ticket_receipt ->\n Transaction_to_sc_rollup_result {consumed_gas; ticket_receipt});\n ]\n\n let transaction_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.transaction_case\n ~encoding:transaction_contract_variant_cases\n ~select:(function\n | Successful_manager_result (Transaction_result _ as op) -> Some op\n | _ -> None)\n ~kind:Kind.Transaction_manager_kind\n ~proj:(function Transaction_result x -> x)\n ~inj:(fun x -> Transaction_result x)\n\n let origination_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.origination_case\n ~encoding:\n (obj6\n (dft \"balance_updates\" Receipt.balance_updates_encoding [])\n (dft \"originated_contracts\" (list Contract.originated_encoding) [])\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (dft \"storage_size\" z Z.zero)\n (dft \"paid_storage_size_diff\" z Z.zero)\n (opt \"lazy_storage_diff\" Lazy_storage.encoding))\n ~select:(function\n | Successful_manager_result (Origination_result _ as op) -> Some op\n | _ -> None)\n ~proj:(function\n | Origination_result\n {\n lazy_storage_diff;\n balance_updates;\n originated_contracts;\n consumed_gas;\n storage_size;\n paid_storage_size_diff;\n } ->\n (* There used to be a [legacy_lazy_storage_diff] returned as the\n first component of the tuple below, and the non-legacy one\n returned as the last component. The legacy one has been removed,\n but it was chosen to keep the non-legacy one at its position,\n hence the order difference with regards to the record above. *)\n ( balance_updates,\n originated_contracts,\n consumed_gas,\n storage_size,\n paid_storage_size_diff,\n lazy_storage_diff ))\n ~kind:Kind.Origination_manager_kind\n ~inj:\n (fun ( balance_updates,\n originated_contracts,\n consumed_gas,\n storage_size,\n paid_storage_size_diff,\n lazy_storage_diff ) ->\n Origination_result\n {\n lazy_storage_diff;\n balance_updates;\n originated_contracts;\n consumed_gas;\n storage_size;\n paid_storage_size_diff;\n })\n\n let register_global_constant_case =\n make\n ~op_case:\n Operation.Encoding.Manager_operations.register_global_constant_case\n ~encoding:\n (obj4\n (dft \"balance_updates\" Receipt.balance_updates_encoding [])\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (dft \"storage_size\" z Z.zero)\n (req \"global_address\" Script_expr_hash.encoding))\n ~select:(function\n | Successful_manager_result (Register_global_constant_result _ as op) ->\n Some op\n | _ -> None)\n ~proj:(function\n | Register_global_constant_result\n {balance_updates; consumed_gas; size_of_constant; global_address} ->\n (balance_updates, consumed_gas, size_of_constant, global_address))\n ~kind:Kind.Register_global_constant_manager_kind\n ~inj:\n (fun (balance_updates, consumed_gas, size_of_constant, global_address) ->\n Register_global_constant_result\n {balance_updates; consumed_gas; size_of_constant; global_address})\n\n let delegation_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.delegation_case\n ~encoding:\n Data_encoding.(\n obj1 (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero))\n ~select:(function\n | Successful_manager_result (Delegation_result _ as op) -> Some op\n | _ -> None)\n ~kind:Kind.Delegation_manager_kind\n ~proj:(function Delegation_result {consumed_gas} -> consumed_gas)\n ~inj:(fun consumed_gas -> Delegation_result {consumed_gas})\n\n let update_consensus_key_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.update_consensus_key_case\n ~encoding:\n Data_encoding.(\n obj1 (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero))\n ~select:(function\n | Successful_manager_result (Update_consensus_key_result _ as op) ->\n Some op\n | _ -> None)\n ~kind:Kind.Update_consensus_key_manager_kind\n ~proj:(function\n | Update_consensus_key_result {consumed_gas} -> consumed_gas)\n ~inj:(fun consumed_gas -> Update_consensus_key_result {consumed_gas})\n\n let set_deposits_limit_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.set_deposits_limit_case\n ~encoding:\n Data_encoding.(\n obj1 (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero))\n ~select:(function\n | Successful_manager_result (Set_deposits_limit_result _ as op) ->\n Some op\n | _ -> None)\n ~kind:Kind.Set_deposits_limit_manager_kind\n ~proj:(function\n | Set_deposits_limit_result {consumed_gas} -> consumed_gas)\n ~inj:(fun consumed_gas -> Set_deposits_limit_result {consumed_gas})\n\n let increase_paid_storage_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.increase_paid_storage_case\n ~encoding:\n Data_encoding.(\n obj2\n (dft \"balance_updates\" Receipt.balance_updates_encoding [])\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero))\n ~select:(function\n | Successful_manager_result (Increase_paid_storage_result _ as op) ->\n Some op\n | _ -> None)\n ~kind:Kind.Increase_paid_storage_manager_kind\n ~proj:(function\n | Increase_paid_storage_result {balance_updates; consumed_gas} ->\n (balance_updates, consumed_gas))\n ~inj:(fun (balance_updates, consumed_gas) ->\n Increase_paid_storage_result {balance_updates; consumed_gas})\n\n let tx_rollup_origination_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.tx_rollup_origination_case\n ~encoding:\n Data_encoding.(\n obj3\n (req \"balance_updates\" Receipt.balance_updates_encoding)\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (req \"originated_rollup\" Tx_rollup.encoding))\n ~select:(function\n | Successful_manager_result (Tx_rollup_origination_result _ as op) ->\n Some op\n | _ -> None)\n ~kind:Kind.Tx_rollup_origination_manager_kind\n ~proj:(function\n | Tx_rollup_origination_result\n {balance_updates; consumed_gas; originated_tx_rollup} ->\n (balance_updates, consumed_gas, originated_tx_rollup))\n ~inj:(fun (balance_updates, consumed_gas, originated_tx_rollup) ->\n Tx_rollup_origination_result\n {balance_updates; consumed_gas; originated_tx_rollup})\n\n let tx_rollup_submit_batch_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.tx_rollup_submit_batch_case\n ~encoding:\n Data_encoding.(\n obj3\n (req \"balance_updates\" Receipt.balance_updates_encoding)\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (req \"paid_storage_size_diff\" n))\n ~select:(function\n | Successful_manager_result (Tx_rollup_submit_batch_result _ as op) ->\n Some op\n | _ -> None)\n ~kind:Kind.Tx_rollup_submit_batch_manager_kind\n ~proj:(function\n | Tx_rollup_submit_batch_result\n {balance_updates; consumed_gas; paid_storage_size_diff} ->\n (balance_updates, consumed_gas, paid_storage_size_diff))\n ~inj:(fun (balance_updates, consumed_gas, paid_storage_size_diff) ->\n Tx_rollup_submit_batch_result\n {balance_updates; consumed_gas; paid_storage_size_diff})\n\n let tx_rollup_commit_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.tx_rollup_commit_case\n ~encoding:\n Data_encoding.(\n obj2\n (req \"balance_updates\" Receipt.balance_updates_encoding)\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero))\n ~select:(function\n | Successful_manager_result (Tx_rollup_commit_result _ as op) -> Some op\n | _ -> None)\n ~kind:Kind.Tx_rollup_commit_manager_kind\n ~proj:(function\n | Tx_rollup_commit_result {balance_updates; consumed_gas} ->\n (balance_updates, consumed_gas))\n ~inj:(fun (balance_updates, consumed_gas) ->\n Tx_rollup_commit_result {balance_updates; consumed_gas})\n\n let tx_rollup_return_bond_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.tx_rollup_return_bond_case\n ~encoding:\n Data_encoding.(\n obj2\n (req \"balance_updates\" Receipt.balance_updates_encoding)\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero))\n ~select:(function\n | Successful_manager_result (Tx_rollup_return_bond_result _ as op) ->\n Some op\n | _ -> None)\n ~kind:Kind.Tx_rollup_return_bond_manager_kind\n ~proj:(function\n | Tx_rollup_return_bond_result {balance_updates; consumed_gas} ->\n (balance_updates, consumed_gas))\n ~inj:(fun (balance_updates, consumed_gas) ->\n Tx_rollup_return_bond_result {balance_updates; consumed_gas})\n\n let tx_rollup_finalize_commitment_case =\n make\n ~op_case:\n Operation.Encoding.Manager_operations.tx_rollup_finalize_commitment_case\n ~encoding:\n Data_encoding.(\n obj3\n (req \"balance_updates\" Receipt.balance_updates_encoding)\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (req \"level\" Tx_rollup_level.encoding))\n ~select:(function\n | Successful_manager_result\n (Tx_rollup_finalize_commitment_result _ as op) ->\n Some op\n | _ -> None)\n ~kind:Kind.Tx_rollup_finalize_commitment_manager_kind\n ~proj:(function\n | Tx_rollup_finalize_commitment_result\n {balance_updates; consumed_gas; level} ->\n (balance_updates, consumed_gas, level))\n ~inj:(fun (balance_updates, consumed_gas, level) ->\n Tx_rollup_finalize_commitment_result\n {balance_updates; consumed_gas; level})\n\n let tx_rollup_remove_commitment_case =\n make\n ~op_case:\n Operation.Encoding.Manager_operations.tx_rollup_remove_commitment_case\n ~encoding:\n Data_encoding.(\n obj3\n (req \"balance_updates\" Receipt.balance_updates_encoding)\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (req \"level\" Tx_rollup_level.encoding))\n ~select:(function\n | Successful_manager_result (Tx_rollup_remove_commitment_result _ as op)\n ->\n Some op\n | _ -> None)\n ~kind:Kind.Tx_rollup_remove_commitment_manager_kind\n ~proj:(function\n | Tx_rollup_remove_commitment_result\n {balance_updates; consumed_gas; level} ->\n (balance_updates, consumed_gas, level))\n ~inj:(fun (balance_updates, consumed_gas, level) ->\n Tx_rollup_remove_commitment_result\n {balance_updates; consumed_gas; level})\n\n let tx_rollup_rejection_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.tx_rollup_rejection_case\n ~encoding:\n Data_encoding.(\n obj2\n (req \"balance_updates\" Receipt.balance_updates_encoding)\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero))\n ~select:(function\n | Successful_manager_result (Tx_rollup_rejection_result _ as op) ->\n Some op\n | _ -> None)\n ~kind:Kind.Tx_rollup_rejection_manager_kind\n ~proj:(function\n | Tx_rollup_rejection_result {balance_updates; consumed_gas} ->\n (balance_updates, consumed_gas))\n ~inj:(fun (balance_updates, consumed_gas) ->\n Tx_rollup_rejection_result {balance_updates; consumed_gas})\n\n let tx_rollup_dispatch_tickets_case =\n make\n ~op_case:\n Operation.Encoding.Manager_operations.tx_rollup_dispatch_tickets_case\n ~encoding:\n Data_encoding.(\n obj3\n (req \"balance_updates\" Receipt.balance_updates_encoding)\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (dft \"paid_storage_size_diff\" z Z.zero))\n ~select:(function\n | Successful_manager_result (Tx_rollup_dispatch_tickets_result _ as op)\n ->\n Some op\n | _ -> None)\n ~kind:Kind.Tx_rollup_dispatch_tickets_manager_kind\n ~proj:(function\n | Tx_rollup_dispatch_tickets_result\n {balance_updates; consumed_gas; paid_storage_size_diff} ->\n (balance_updates, consumed_gas, paid_storage_size_diff))\n ~inj:(fun (balance_updates, consumed_gas, paid_storage_size_diff) ->\n Tx_rollup_dispatch_tickets_result\n {balance_updates; consumed_gas; paid_storage_size_diff})\n\n let transfer_ticket_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.transfer_ticket_case\n ~encoding:\n Data_encoding.(\n obj4\n (req \"balance_updates\" Receipt.balance_updates_encoding)\n (req \"ticket_updates\" Ticket_receipt.encoding)\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (dft \"paid_storage_size_diff\" z Z.zero))\n ~select:(function\n | Successful_manager_result (Transfer_ticket_result _ as op) -> Some op\n | _ -> None)\n ~kind:Kind.Transfer_ticket_manager_kind\n ~proj:(function\n | Transfer_ticket_result\n {\n balance_updates;\n ticket_receipt;\n consumed_gas;\n paid_storage_size_diff;\n } ->\n ( balance_updates,\n ticket_receipt,\n consumed_gas,\n paid_storage_size_diff ))\n ~inj:\n (fun ( balance_updates,\n ticket_receipt,\n consumed_gas,\n paid_storage_size_diff ) ->\n Transfer_ticket_result\n {\n balance_updates;\n ticket_receipt;\n consumed_gas;\n paid_storage_size_diff;\n })\n\n let dal_publish_slot_header_case =\n make\n ~op_case:\n Operation.Encoding.Manager_operations.dal_publish_slot_header_case\n ~encoding:\n (obj1 (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero))\n ~select:(function\n | Successful_manager_result (Dal_publish_slot_header_result _ as op) ->\n Some op\n | _ -> None)\n ~proj:(function\n | Dal_publish_slot_header_result {consumed_gas} -> consumed_gas)\n ~kind:Kind.Dal_publish_slot_header_manager_kind\n ~inj:(fun consumed_gas -> Dal_publish_slot_header_result {consumed_gas})\n\n let zk_rollup_origination_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.zk_rollup_origination_case\n ~encoding:\n Data_encoding.(\n obj4\n (req \"balance_updates\" Receipt.balance_updates_encoding)\n (req \"originated_zk_rollup\" Zk_rollup.Address.encoding)\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (req \"size\" z))\n ~select:(function\n | Successful_manager_result (Zk_rollup_origination_result _ as op) ->\n Some op\n | _ -> None)\n ~kind:Kind.Zk_rollup_origination_manager_kind\n ~proj:(function\n | Zk_rollup_origination_result\n {balance_updates; originated_zk_rollup; consumed_gas; storage_size}\n ->\n (balance_updates, originated_zk_rollup, consumed_gas, storage_size))\n ~inj:\n (fun (balance_updates, originated_zk_rollup, consumed_gas, storage_size) ->\n Zk_rollup_origination_result\n {balance_updates; originated_zk_rollup; consumed_gas; storage_size})\n\n let zk_rollup_publish_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.zk_rollup_publish_case\n ~encoding:\n Data_encoding.(\n obj3\n (req \"balance_updates\" Receipt.balance_updates_encoding)\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (req \"size\" z))\n ~select:(function\n | Successful_manager_result (Zk_rollup_publish_result _ as op) ->\n Some op\n | _ -> None)\n ~kind:Kind.Zk_rollup_publish_manager_kind\n ~proj:(function\n | Zk_rollup_publish_result\n {balance_updates; consumed_gas; paid_storage_size_diff} ->\n (balance_updates, consumed_gas, paid_storage_size_diff))\n ~inj:(fun (balance_updates, consumed_gas, paid_storage_size_diff) ->\n Zk_rollup_publish_result\n {balance_updates; consumed_gas; paid_storage_size_diff})\n\n let zk_rollup_update_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.zk_rollup_update_case\n ~encoding:\n Data_encoding.(\n obj3\n (req \"balance_updates\" Receipt.balance_updates_encoding)\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (dft \"paid_storage_size_diff\" z Z.zero))\n ~select:(function\n | Successful_manager_result (Zk_rollup_update_result _ as op) -> Some op\n | _ -> None)\n ~kind:Kind.Zk_rollup_update_manager_kind\n ~proj:(function\n | Zk_rollup_update_result\n {balance_updates; consumed_gas; paid_storage_size_diff} ->\n (balance_updates, consumed_gas, paid_storage_size_diff))\n ~inj:(fun (balance_updates, consumed_gas, paid_storage_size_diff) ->\n Zk_rollup_update_result\n {balance_updates; consumed_gas; paid_storage_size_diff})\n\n let sc_rollup_originate_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.sc_rollup_originate_case\n ~encoding:\n (obj5\n (req \"balance_updates\" Receipt.balance_updates_encoding)\n (req \"address\" Sc_rollup.Address.encoding)\n (req \"genesis_commitment_hash\" Sc_rollup.Commitment.Hash.encoding)\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (req \"size\" z))\n ~select:(function\n | Successful_manager_result (Sc_rollup_originate_result _ as op) ->\n Some op\n | _ -> None)\n ~proj:(function\n | Sc_rollup_originate_result\n {\n balance_updates;\n address;\n genesis_commitment_hash;\n consumed_gas;\n size;\n } ->\n ( balance_updates,\n address,\n genesis_commitment_hash,\n consumed_gas,\n size ))\n ~kind:Kind.Sc_rollup_originate_manager_kind\n ~inj:\n (fun ( balance_updates,\n address,\n genesis_commitment_hash,\n consumed_gas,\n size ) ->\n Sc_rollup_originate_result\n {\n balance_updates;\n address;\n genesis_commitment_hash;\n consumed_gas;\n size;\n })\n\n let sc_rollup_add_messages_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.sc_rollup_add_messages_case\n ~encoding:\n (obj1 (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero))\n ~select:(function\n | Successful_manager_result (Sc_rollup_add_messages_result _ as op) ->\n Some op\n | _ -> None)\n ~proj:(function\n | Sc_rollup_add_messages_result {consumed_gas} -> consumed_gas)\n ~kind:Kind.Sc_rollup_add_messages_manager_kind\n ~inj:(fun consumed_gas -> Sc_rollup_add_messages_result {consumed_gas})\n\n let sc_rollup_cement_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.sc_rollup_cement_case\n ~encoding:\n (obj2\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (req \"inbox_level\" Raw_level.encoding))\n ~select:(function\n | Successful_manager_result (Sc_rollup_cement_result _ as op) -> Some op\n | _ -> None)\n ~proj:(function\n | Sc_rollup_cement_result {consumed_gas; inbox_level} ->\n (consumed_gas, inbox_level))\n ~kind:Kind.Sc_rollup_cement_manager_kind\n ~inj:(fun (consumed_gas, inbox_level) ->\n Sc_rollup_cement_result {consumed_gas; inbox_level})\n\n let sc_rollup_publish_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.sc_rollup_publish_case\n ~encoding:\n (obj4\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (req \"staked_hash\" Sc_rollup.Commitment.Hash.encoding)\n (req \"published_at_level\" Raw_level.encoding)\n (req \"balance_updates\" Receipt.balance_updates_encoding))\n ~select:(function\n | Successful_manager_result (Sc_rollup_publish_result _ as op) ->\n Some op\n | _ -> None)\n ~proj:(function\n | Sc_rollup_publish_result\n {consumed_gas; staked_hash; published_at_level; balance_updates} ->\n (consumed_gas, staked_hash, published_at_level, balance_updates))\n ~kind:Kind.Sc_rollup_publish_manager_kind\n ~inj:\n (fun (consumed_gas, staked_hash, published_at_level, balance_updates) ->\n Sc_rollup_publish_result\n {consumed_gas; staked_hash; published_at_level; balance_updates})\n\n let sc_rollup_refute_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.sc_rollup_refute_case\n ~encoding:\n Data_encoding.(\n obj3\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (req \"game_status\" Sc_rollup.Game.status_encoding)\n (req \"balance_updates\" Receipt.balance_updates_encoding))\n ~select:(function\n | Successful_manager_result (Sc_rollup_refute_result _ as op) -> Some op\n | _ -> None)\n ~proj:(function\n | Sc_rollup_refute_result {consumed_gas; game_status; balance_updates}\n ->\n (consumed_gas, game_status, balance_updates))\n ~kind:Kind.Sc_rollup_refute_manager_kind\n ~inj:(fun (consumed_gas, game_status, balance_updates) ->\n Sc_rollup_refute_result {consumed_gas; game_status; balance_updates})\n\n let sc_rollup_timeout_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.sc_rollup_timeout_case\n ~encoding:\n (obj3\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (req \"game_status\" Sc_rollup.Game.status_encoding)\n (req \"balance_updates\" Receipt.balance_updates_encoding))\n ~select:(function\n | Successful_manager_result (Sc_rollup_timeout_result _ as op) ->\n Some op\n | _ -> None)\n ~proj:(function\n | Sc_rollup_timeout_result {consumed_gas; game_status; balance_updates}\n ->\n (consumed_gas, game_status, balance_updates))\n ~kind:Kind.Sc_rollup_timeout_manager_kind\n ~inj:(fun (consumed_gas, game_status, balance_updates) ->\n Sc_rollup_timeout_result {consumed_gas; game_status; balance_updates})\n\n let sc_rollup_execute_outbox_message_case =\n make\n ~op_case:\n Operation.Encoding.Manager_operations\n .sc_rollup_execute_outbox_message_case\n ~encoding:\n Data_encoding.(\n obj4\n (req \"balance_updates\" Receipt.balance_updates_encoding)\n (req \"ticket_updates\" Ticket_receipt.encoding)\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero)\n (dft \"paid_storage_size_diff\" z Z.zero))\n ~select:(function\n | Successful_manager_result\n (Sc_rollup_execute_outbox_message_result _ as op) ->\n Some op\n | _ -> None)\n ~kind:Kind.Sc_rollup_execute_outbox_message_manager_kind\n ~proj:(function\n | Sc_rollup_execute_outbox_message_result\n {\n balance_updates;\n ticket_receipt;\n consumed_gas;\n paid_storage_size_diff;\n } ->\n ( balance_updates,\n ticket_receipt,\n consumed_gas,\n paid_storage_size_diff ))\n ~inj:\n (fun ( balance_updates,\n ticket_receipt,\n consumed_gas,\n paid_storage_size_diff ) ->\n Sc_rollup_execute_outbox_message_result\n {\n balance_updates;\n ticket_receipt;\n consumed_gas;\n paid_storage_size_diff;\n })\n\n let sc_rollup_recover_bond_case =\n make\n ~op_case:Operation.Encoding.Manager_operations.sc_rollup_recover_bond_case\n ~encoding:\n Data_encoding.(\n obj2\n (req \"balance_updates\" Receipt.balance_updates_encoding)\n (dft \"consumed_milligas\" Gas.Arith.n_fp_encoding Gas.Arith.zero))\n ~select:(function\n | Successful_manager_result (Sc_rollup_recover_bond_result _ as op) ->\n Some op\n | _ -> None)\n ~kind:Kind.Sc_rollup_recover_bond_manager_kind\n ~proj:(function\n | Sc_rollup_recover_bond_result {balance_updates; consumed_gas} ->\n (balance_updates, consumed_gas))\n ~inj:(fun (balance_updates, consumed_gas) ->\n Sc_rollup_recover_bond_result {balance_updates; consumed_gas})\nend\n\nlet successful_manager_operation_result_encoding :\n packed_successful_manager_operation_result Data_encoding.t =\n let make (type kind)\n (Manager_result.MCase res_case : kind Manager_result.case) =\n let (Operation.Encoding.Manager_operations.MCase op_case) =\n res_case.op_case\n in\n case\n (Tag op_case.tag)\n ~title:op_case.name\n (merge_objs (obj1 (req \"kind\" (constant op_case.name))) res_case.encoding)\n (fun res ->\n match res_case.select res with\n | Some res -> Some ((), res_case.proj res)\n | None -> None)\n (fun ((), res) -> Successful_manager_result (res_case.inj res))\n in\n def \"operation.alpha.successful_manager_operation_result\"\n @@ union\n [\n make Manager_result.reveal_case;\n make Manager_result.transaction_case;\n make Manager_result.origination_case;\n make Manager_result.delegation_case;\n make Manager_result.update_consensus_key_case;\n make Manager_result.set_deposits_limit_case;\n make Manager_result.increase_paid_storage_case;\n make Manager_result.sc_rollup_originate_case;\n ]\n\ntype 'kind contents_result =\n | Preendorsement_result : {\n balance_updates : Receipt.balance_updates;\n delegate : Signature.public_key_hash;\n consensus_key : Signature.public_key_hash;\n preendorsement_power : int;\n }\n -> Kind.preendorsement contents_result\n | Endorsement_result : {\n balance_updates : Receipt.balance_updates;\n delegate : Signature.public_key_hash;\n consensus_key : Signature.public_key_hash;\n endorsement_power : int;\n }\n -> Kind.endorsement contents_result\n | Dal_attestation_result : {\n delegate : Signature.Public_key_hash.t;\n }\n -> Kind.dal_attestation contents_result\n | Seed_nonce_revelation_result :\n Receipt.balance_updates\n -> Kind.seed_nonce_revelation contents_result\n | Vdf_revelation_result :\n Receipt.balance_updates\n -> Kind.vdf_revelation contents_result\n | Double_endorsement_evidence_result :\n Receipt.balance_updates\n -> Kind.double_endorsement_evidence contents_result\n | Double_preendorsement_evidence_result :\n Receipt.balance_updates\n -> Kind.double_preendorsement_evidence contents_result\n | Double_baking_evidence_result :\n Receipt.balance_updates\n -> Kind.double_baking_evidence contents_result\n | Activate_account_result :\n Receipt.balance_updates\n -> Kind.activate_account contents_result\n | Proposals_result : Kind.proposals contents_result\n | Ballot_result : Kind.ballot contents_result\n | Drain_delegate_result : {\n balance_updates : Receipt.balance_updates;\n allocated_destination_contract : bool;\n }\n -> Kind.drain_delegate contents_result\n | Manager_operation_result : {\n balance_updates : Receipt.balance_updates;\n operation_result : 'kind manager_operation_result;\n internal_operation_results : packed_internal_operation_result list;\n }\n -> 'kind Kind.manager contents_result\n\ntype packed_contents_result =\n | Contents_result : 'kind contents_result -> packed_contents_result\n\ntype packed_contents_and_result =\n | Contents_and_result :\n 'kind Operation.contents * 'kind contents_result\n -> packed_contents_and_result\n\ntype ('a, 'b) eq = Eq : ('a, 'a) eq\n\nlet equal_manager_kind :\n type a b. a Kind.manager -> b Kind.manager -> (a, b) eq option =\n fun ka kb ->\n match (ka, kb) with\n | Kind.Reveal_manager_kind, Kind.Reveal_manager_kind -> Some Eq\n | Kind.Reveal_manager_kind, _ -> None\n | Kind.Transaction_manager_kind, Kind.Transaction_manager_kind -> Some Eq\n | Kind.Transaction_manager_kind, _ -> None\n | Kind.Origination_manager_kind, Kind.Origination_manager_kind -> Some Eq\n | Kind.Origination_manager_kind, _ -> None\n | Kind.Delegation_manager_kind, Kind.Delegation_manager_kind -> Some Eq\n | Kind.Delegation_manager_kind, _ -> None\n | ( Kind.Update_consensus_key_manager_kind,\n Kind.Update_consensus_key_manager_kind ) ->\n Some Eq\n | Kind.Update_consensus_key_manager_kind, _ -> None\n | ( Kind.Register_global_constant_manager_kind,\n Kind.Register_global_constant_manager_kind ) ->\n Some Eq\n | Kind.Event_manager_kind, Kind.Event_manager_kind -> Some Eq\n | Kind.Event_manager_kind, _ -> None\n | Kind.Register_global_constant_manager_kind, _ -> None\n | Kind.Set_deposits_limit_manager_kind, Kind.Set_deposits_limit_manager_kind\n ->\n Some Eq\n | Kind.Set_deposits_limit_manager_kind, _ -> None\n | ( Kind.Increase_paid_storage_manager_kind,\n Kind.Increase_paid_storage_manager_kind ) ->\n Some Eq\n | Kind.Increase_paid_storage_manager_kind, _ -> None\n | ( Kind.Tx_rollup_origination_manager_kind,\n Kind.Tx_rollup_origination_manager_kind ) ->\n Some Eq\n | Kind.Tx_rollup_origination_manager_kind, _ -> None\n | ( Kind.Tx_rollup_submit_batch_manager_kind,\n Kind.Tx_rollup_submit_batch_manager_kind ) ->\n Some Eq\n | Kind.Tx_rollup_submit_batch_manager_kind, _ -> None\n | Kind.Tx_rollup_commit_manager_kind, Kind.Tx_rollup_commit_manager_kind ->\n Some Eq\n | Kind.Tx_rollup_commit_manager_kind, _ -> None\n | ( Kind.Tx_rollup_return_bond_manager_kind,\n Kind.Tx_rollup_return_bond_manager_kind ) ->\n Some Eq\n | Kind.Tx_rollup_return_bond_manager_kind, _ -> None\n | ( Kind.Tx_rollup_finalize_commitment_manager_kind,\n Kind.Tx_rollup_finalize_commitment_manager_kind ) ->\n Some Eq\n | Kind.Tx_rollup_finalize_commitment_manager_kind, _ -> None\n | ( Kind.Tx_rollup_remove_commitment_manager_kind,\n Kind.Tx_rollup_remove_commitment_manager_kind ) ->\n Some Eq\n | Kind.Tx_rollup_remove_commitment_manager_kind, _ -> None\n | Kind.Tx_rollup_rejection_manager_kind, Kind.Tx_rollup_rejection_manager_kind\n ->\n Some Eq\n | Kind.Tx_rollup_rejection_manager_kind, _ -> None\n | ( Kind.Tx_rollup_dispatch_tickets_manager_kind,\n Kind.Tx_rollup_dispatch_tickets_manager_kind ) ->\n Some Eq\n | Kind.Tx_rollup_dispatch_tickets_manager_kind, _ -> None\n | Kind.Transfer_ticket_manager_kind, Kind.Transfer_ticket_manager_kind ->\n Some Eq\n | Kind.Transfer_ticket_manager_kind, _ -> None\n | ( Kind.Dal_publish_slot_header_manager_kind,\n Kind.Dal_publish_slot_header_manager_kind ) ->\n Some Eq\n | Kind.Dal_publish_slot_header_manager_kind, _ -> None\n | Kind.Sc_rollup_originate_manager_kind, Kind.Sc_rollup_originate_manager_kind\n ->\n Some Eq\n | Kind.Sc_rollup_originate_manager_kind, _ -> None\n | ( Kind.Sc_rollup_add_messages_manager_kind,\n Kind.Sc_rollup_add_messages_manager_kind ) ->\n Some Eq\n | Kind.Sc_rollup_add_messages_manager_kind, _ -> None\n | Kind.Sc_rollup_cement_manager_kind, Kind.Sc_rollup_cement_manager_kind ->\n Some Eq\n | Kind.Sc_rollup_cement_manager_kind, _ -> None\n | Kind.Sc_rollup_publish_manager_kind, Kind.Sc_rollup_publish_manager_kind ->\n Some Eq\n | Kind.Sc_rollup_publish_manager_kind, _ -> None\n | Kind.Sc_rollup_refute_manager_kind, Kind.Sc_rollup_refute_manager_kind ->\n Some Eq\n | Kind.Sc_rollup_refute_manager_kind, _ -> None\n | Kind.Sc_rollup_timeout_manager_kind, Kind.Sc_rollup_timeout_manager_kind ->\n Some Eq\n | Kind.Sc_rollup_timeout_manager_kind, _ -> None\n | ( Kind.Sc_rollup_execute_outbox_message_manager_kind,\n Kind.Sc_rollup_execute_outbox_message_manager_kind ) ->\n Some Eq\n | Kind.Sc_rollup_execute_outbox_message_manager_kind, _ -> None\n | ( Kind.Sc_rollup_recover_bond_manager_kind,\n Kind.Sc_rollup_recover_bond_manager_kind ) ->\n Some Eq\n | Kind.Sc_rollup_recover_bond_manager_kind, _ -> None\n | ( Kind.Zk_rollup_origination_manager_kind,\n Kind.Zk_rollup_origination_manager_kind ) ->\n Some Eq\n | Kind.Zk_rollup_origination_manager_kind, _ -> None\n | Kind.Zk_rollup_publish_manager_kind, Kind.Zk_rollup_publish_manager_kind ->\n Some Eq\n | Kind.Zk_rollup_publish_manager_kind, _ -> None\n | Kind.Zk_rollup_update_manager_kind, Kind.Zk_rollup_update_manager_kind ->\n Some Eq\n | Kind.Zk_rollup_update_manager_kind, _ -> None\n\nmodule Encoding = struct\n type 'kind case =\n | Case : {\n op_case : 'kind Operation.Encoding.case;\n encoding : 'a Data_encoding.t;\n select : packed_contents_result -> 'kind contents_result option;\n mselect :\n packed_contents_and_result ->\n ('kind contents * 'kind contents_result) option;\n proj : 'kind contents_result -> 'a;\n inj : 'a -> 'kind contents_result;\n }\n -> 'kind case\n\n let tagged_case tag name args proj inj =\n let open Data_encoding in\n case\n tag\n ~title:(String.capitalize_ascii name)\n (merge_objs (obj1 (req \"kind\" (constant name))) args)\n (fun x -> match proj x with None -> None | Some x -> Some ((), x))\n (fun ((), x) -> inj x)\n\n let preendorsement_case =\n Case\n {\n op_case = Operation.Encoding.preendorsement_case;\n encoding =\n obj4\n (dft \"balance_updates\" Receipt.balance_updates_encoding [])\n (req \"delegate\" Signature.Public_key_hash.encoding)\n (req \"preendorsement_power\" int31)\n (req \"consensus_key\" Signature.Public_key_hash.encoding);\n select =\n (function\n | Contents_result (Preendorsement_result _ as op) -> Some op\n | _ -> None);\n mselect =\n (function\n | Contents_and_result ((Preendorsement _ as op), res) -> Some (op, res)\n | _ -> None);\n proj =\n (function\n | Preendorsement_result\n {balance_updates; delegate; consensus_key; preendorsement_power}\n ->\n (balance_updates, delegate, preendorsement_power, consensus_key));\n inj =\n (fun (balance_updates, delegate, preendorsement_power, consensus_key) ->\n Preendorsement_result\n {balance_updates; delegate; consensus_key; preendorsement_power});\n }\n\n let endorsement_case =\n Case\n {\n op_case = Operation.Encoding.endorsement_case;\n encoding =\n obj4\n (dft \"balance_updates\" Receipt.balance_updates_encoding [])\n (req \"delegate\" Signature.Public_key_hash.encoding)\n (req \"endorsement_power\" int31)\n (req \"consensus_key\" Signature.Public_key_hash.encoding);\n select =\n (function\n | Contents_result (Endorsement_result _ as op) -> Some op | _ -> None);\n mselect =\n (function\n | Contents_and_result ((Endorsement _ as op), res) -> Some (op, res)\n | _ -> None);\n proj =\n (function\n | Endorsement_result\n {balance_updates; delegate; consensus_key; endorsement_power} ->\n (balance_updates, delegate, endorsement_power, consensus_key));\n inj =\n (fun (balance_updates, delegate, endorsement_power, consensus_key) ->\n Endorsement_result\n {balance_updates; delegate; consensus_key; endorsement_power});\n }\n\n let dal_attestation_case =\n Case\n {\n op_case = Operation.Encoding.dal_attestation_case;\n encoding = obj1 (req \"delegate\" Signature.Public_key_hash.encoding);\n select =\n (function\n | Contents_result (Dal_attestation_result _ as op) -> Some op\n | _ -> None);\n mselect =\n (function\n | Contents_and_result ((Dal_attestation _ as op), res) ->\n Some (op, res)\n | _ -> None);\n proj = (function Dal_attestation_result {delegate} -> delegate);\n inj = (fun delegate -> Dal_attestation_result {delegate});\n }\n\n let seed_nonce_revelation_case =\n Case\n {\n op_case = Operation.Encoding.seed_nonce_revelation_case;\n encoding =\n obj1 (dft \"balance_updates\" Receipt.balance_updates_encoding []);\n select =\n (function\n | Contents_result (Seed_nonce_revelation_result _ as op) -> Some op\n | _ -> None);\n mselect =\n (function\n | Contents_and_result ((Seed_nonce_revelation _ as op), res) ->\n Some (op, res)\n | _ -> None);\n proj = (fun (Seed_nonce_revelation_result bus) -> bus);\n inj = (fun bus -> Seed_nonce_revelation_result bus);\n }\n\n let vdf_revelation_case =\n Case\n {\n op_case = Operation.Encoding.vdf_revelation_case;\n encoding =\n obj1 (dft \"balance_updates\" Receipt.balance_updates_encoding []);\n select =\n (function\n | Contents_result (Vdf_revelation_result _ as op) -> Some op\n | _ -> None);\n mselect =\n (function\n | Contents_and_result ((Vdf_revelation _ as op), res) -> Some (op, res)\n | _ -> None);\n proj = (fun (Vdf_revelation_result bus) -> bus);\n inj = (fun bus -> Vdf_revelation_result bus);\n }\n\n let double_endorsement_evidence_case =\n Case\n {\n op_case = Operation.Encoding.double_endorsement_evidence_case;\n encoding =\n obj1 (dft \"balance_updates\" Receipt.balance_updates_encoding []);\n select =\n (function\n | Contents_result (Double_endorsement_evidence_result _ as op) ->\n Some op\n | _ -> None);\n mselect =\n (function\n | Contents_and_result ((Double_endorsement_evidence _ as op), res) ->\n Some (op, res)\n | _ -> None);\n proj = (fun (Double_endorsement_evidence_result bus) -> bus);\n inj = (fun bus -> Double_endorsement_evidence_result bus);\n }\n\n let double_preendorsement_evidence_case =\n Case\n {\n op_case = Operation.Encoding.double_preendorsement_evidence_case;\n encoding =\n obj1 (dft \"balance_updates\" Receipt.balance_updates_encoding []);\n select =\n (function\n | Contents_result (Double_preendorsement_evidence_result _ as op) ->\n Some op\n | _ -> None);\n mselect =\n (function\n | Contents_and_result ((Double_preendorsement_evidence _ as op), res)\n ->\n Some (op, res)\n | _ -> None);\n proj = (fun (Double_preendorsement_evidence_result bus) -> bus);\n inj = (fun bus -> Double_preendorsement_evidence_result bus);\n }\n\n let double_baking_evidence_case =\n Case\n {\n op_case = Operation.Encoding.double_baking_evidence_case;\n encoding =\n obj1 (dft \"balance_updates\" Receipt.balance_updates_encoding []);\n select =\n (function\n | Contents_result (Double_baking_evidence_result _ as op) -> Some op\n | _ -> None);\n mselect =\n (function\n | Contents_and_result ((Double_baking_evidence _ as op), res) ->\n Some (op, res)\n | _ -> None);\n proj = (fun (Double_baking_evidence_result bus) -> bus);\n inj = (fun bus -> Double_baking_evidence_result bus);\n }\n\n let activate_account_case =\n Case\n {\n op_case = Operation.Encoding.activate_account_case;\n encoding =\n obj1 (dft \"balance_updates\" Receipt.balance_updates_encoding []);\n select =\n (function\n | Contents_result (Activate_account_result _ as op) -> Some op\n | _ -> None);\n mselect =\n (function\n | Contents_and_result ((Activate_account _ as op), res) ->\n Some (op, res)\n | _ -> None);\n proj = (fun (Activate_account_result bus) -> bus);\n inj = (fun bus -> Activate_account_result bus);\n }\n\n let proposals_case =\n Case\n {\n op_case = Operation.Encoding.proposals_case;\n encoding = Data_encoding.empty;\n select =\n (function\n | Contents_result (Proposals_result as op) -> Some op | _ -> None);\n mselect =\n (function\n | Contents_and_result ((Proposals _ as op), res) -> Some (op, res)\n | _ -> None);\n proj = (fun Proposals_result -> ());\n inj = (fun () -> Proposals_result);\n }\n\n let ballot_case =\n Case\n {\n op_case = Operation.Encoding.ballot_case;\n encoding = Data_encoding.empty;\n select =\n (function\n | Contents_result (Ballot_result as op) -> Some op | _ -> None);\n mselect =\n (function\n | Contents_and_result ((Ballot _ as op), res) -> Some (op, res)\n | _ -> None);\n proj = (fun Ballot_result -> ());\n inj = (fun () -> Ballot_result);\n }\n\n let drain_delegate_case =\n Case\n {\n op_case = Operation.Encoding.drain_delegate_case;\n encoding =\n Data_encoding.(\n obj2\n (dft \"balance_updates\" Receipt.balance_updates_encoding [])\n (dft \"allocated_destination_contract\" bool false));\n select =\n (function\n | Contents_result (Drain_delegate_result _ as op) -> Some op\n | _ -> None);\n mselect =\n (function\n | Contents_and_result ((Drain_delegate _ as op), res) -> Some (op, res)\n | _ -> None);\n proj =\n (function\n | Drain_delegate_result\n {balance_updates; allocated_destination_contract} ->\n (balance_updates, allocated_destination_contract));\n inj =\n (fun (balance_updates, allocated_destination_contract) ->\n Drain_delegate_result\n {balance_updates; allocated_destination_contract});\n }\n\n let make_manager_case (type kind)\n (Operation.Encoding.Case op_case :\n kind Kind.manager Operation.Encoding.case)\n (Manager_result.MCase res_case : kind Manager_result.case) mselect =\n Case\n {\n op_case = Operation.Encoding.Case op_case;\n encoding =\n obj3\n (dft \"balance_updates\" Receipt.balance_updates_encoding [])\n (req \"operation_result\" res_case.t)\n (dft\n \"internal_operation_results\"\n (list internal_operation_result_encoding)\n []);\n select =\n (function\n | Contents_result\n (Manager_operation_result\n ({operation_result = Applied res; _} as op)) -> (\n match res_case.select (Successful_manager_result res) with\n | Some res ->\n Some\n (Manager_operation_result\n {op with operation_result = Applied res})\n | None -> None)\n | Contents_result\n (Manager_operation_result\n ({operation_result = Backtracked (res, errs); _} as op)) -> (\n match res_case.select (Successful_manager_result res) with\n | Some res ->\n Some\n (Manager_operation_result\n {op with operation_result = Backtracked (res, errs)})\n | None -> None)\n | Contents_result\n (Manager_operation_result\n ({operation_result = Skipped kind; _} as op)) -> (\n match equal_manager_kind kind res_case.kind with\n | None -> None\n | Some Eq ->\n Some\n (Manager_operation_result\n {op with operation_result = Skipped kind}))\n | Contents_result\n (Manager_operation_result\n ({operation_result = Failed (kind, errs); _} as op)) -> (\n match equal_manager_kind kind res_case.kind with\n | None -> None\n | Some Eq ->\n Some\n (Manager_operation_result\n {op with operation_result = Failed (kind, errs)}))\n | Contents_result (Preendorsement_result _) -> None\n | Contents_result (Endorsement_result _) -> None\n | Contents_result (Dal_attestation_result _) -> None\n | Contents_result Ballot_result -> None\n | Contents_result (Seed_nonce_revelation_result _) -> None\n | Contents_result (Vdf_revelation_result _) -> None\n | Contents_result (Double_endorsement_evidence_result _) -> None\n | Contents_result (Double_preendorsement_evidence_result _) -> None\n | Contents_result (Double_baking_evidence_result _) -> None\n | Contents_result (Activate_account_result _) -> None\n | Contents_result (Drain_delegate_result _) -> None\n | Contents_result Proposals_result -> None);\n mselect;\n proj =\n (fun (Manager_operation_result\n {\n balance_updates = bus;\n operation_result = r;\n internal_operation_results = rs;\n }) ->\n (bus, r, rs));\n inj =\n (fun (bus, r, rs) ->\n Manager_operation_result\n {\n balance_updates = bus;\n operation_result = r;\n internal_operation_results = rs;\n });\n }\n\n let reveal_case =\n make_manager_case\n Operation.Encoding.reveal_case\n Manager_result.reveal_case\n (function\n | Contents_and_result\n ((Manager_operation {operation = Reveal _; _} as op), res) ->\n Some (op, res)\n | _ -> None)\n\n let transaction_case =\n make_manager_case\n Operation.Encoding.transaction_case\n Manager_result.transaction_case\n (function\n | Contents_and_result\n ((Manager_operation {operation = Transaction _; _} as op), res) ->\n Some (op, res)\n | _ -> None)\n\n let origination_case =\n make_manager_case\n Operation.Encoding.origination_case\n Manager_result.origination_case\n (function\n | Contents_and_result\n ((Manager_operation {operation = Origination _; _} as op), res) ->\n Some (op, res)\n | _ -> None)\n\n let delegation_case =\n make_manager_case\n Operation.Encoding.delegation_case\n Manager_result.delegation_case\n (function\n | Contents_and_result\n ((Manager_operation {operation = Delegation _; _} as op), res) ->\n Some (op, res)\n | _ -> None)\n\n let update_consensus_key_case =\n make_manager_case\n Operation.Encoding.update_consensus_key_case\n Manager_result.update_consensus_key_case\n (function\n | Contents_and_result\n ( (Manager_operation {operation = Update_consensus_key _; _} as op),\n res ) ->\n Some (op, res)\n | _ -> None)\n\n let register_global_constant_case =\n make_manager_case\n Operation.Encoding.register_global_constant_case\n Manager_result.register_global_constant_case\n (function\n | Contents_and_result\n ( (Manager_operation {operation = Register_global_constant _; _} as\n op),\n res ) ->\n Some (op, res)\n | _ -> None)\n\n let set_deposits_limit_case =\n make_manager_case\n Operation.Encoding.set_deposits_limit_case\n Manager_result.set_deposits_limit_case\n (function\n | Contents_and_result\n ( (Manager_operation {operation = Set_deposits_limit _; _} as op),\n res ) ->\n Some (op, res)\n | _ -> None)\n\n let increase_paid_storage_case =\n make_manager_case\n Operation.Encoding.increase_paid_storage_case\n Manager_result.increase_paid_storage_case\n (function\n | Contents_and_result\n ( (Manager_operation {operation = Increase_paid_storage _; _} as op),\n res ) ->\n Some (op, res)\n | _ -> None)\n\n let tx_rollup_origination_case =\n make_manager_case\n Operation.Encoding.tx_rollup_origination_case\n Manager_result.tx_rollup_origination_case\n (function\n | Contents_and_result\n ( (Manager_operation {operation = Tx_rollup_origination; _} as op),\n res ) ->\n Some (op, res)\n | _ -> None)\n\n let tx_rollup_submit_batch_case =\n make_manager_case\n Operation.Encoding.tx_rollup_submit_batch_case\n Manager_result.tx_rollup_submit_batch_case\n (function\n | Contents_and_result\n ( (Manager_operation {operation = Tx_rollup_submit_batch _; _} as op),\n res ) ->\n Some (op, res)\n | _ -> None)\n\n let tx_rollup_commit_case =\n make_manager_case\n Operation.Encoding.tx_rollup_commit_case\n Manager_result.tx_rollup_commit_case\n (function\n | Contents_and_result\n ((Manager_operation {operation = Tx_rollup_commit _; _} as op), res)\n ->\n Some (op, res)\n | _ -> None)\n\n let tx_rollup_return_bond_case =\n make_manager_case\n Operation.Encoding.tx_rollup_return_bond_case\n Manager_result.tx_rollup_return_bond_case\n (function\n | Contents_and_result\n ( (Manager_operation {operation = Tx_rollup_return_bond _; _} as op),\n res ) ->\n Some (op, res)\n | _ -> None)\n\n let tx_rollup_finalize_commitment_case =\n make_manager_case\n Operation.Encoding.tx_rollup_finalize_commitment_case\n Manager_result.tx_rollup_finalize_commitment_case\n (function\n | Contents_and_result\n ( (Manager_operation {operation = Tx_rollup_finalize_commitment _; _}\n as op),\n res ) ->\n Some (op, res)\n | _ -> None)\n\n let tx_rollup_remove_commitment_case =\n make_manager_case\n Operation.Encoding.tx_rollup_remove_commitment_case\n Manager_result.tx_rollup_remove_commitment_case\n (function\n | Contents_and_result\n ( (Manager_operation {operation = Tx_rollup_remove_commitment _; _}\n as op),\n res ) ->\n Some (op, res)\n | _ -> None)\n\n let tx_rollup_rejection_case =\n make_manager_case\n Operation.Encoding.tx_rollup_rejection_case\n Manager_result.tx_rollup_rejection_case\n (function\n | Contents_and_result\n ( (Manager_operation {operation = Tx_rollup_rejection _; _} as op),\n res ) ->\n Some (op, res)\n | _ -> None)\n\n let tx_rollup_dispatch_tickets_case =\n make_manager_case\n Operation.Encoding.tx_rollup_dispatch_tickets_case\n Manager_result.tx_rollup_dispatch_tickets_case\n (function\n | Contents_and_result\n ( (Manager_operation {operation = Tx_rollup_dispatch_tickets _; _}\n as op),\n res ) ->\n Some (op, res)\n | _ -> None)\n\n let transfer_ticket_case =\n make_manager_case\n Operation.Encoding.transfer_ticket_case\n Manager_result.transfer_ticket_case\n (function\n | Contents_and_result\n ((Manager_operation {operation = Transfer_ticket _; _} as op), res)\n ->\n Some (op, res)\n | _ -> None)\n\n let dal_publish_slot_header_case =\n make_manager_case\n Operation.Encoding.dal_publish_slot_header_case\n Manager_result.dal_publish_slot_header_case\n (function\n | Contents_and_result\n ( (Manager_operation {operation = Dal_publish_slot_header _; _} as\n op),\n res ) ->\n Some (op, res)\n | _ -> None)\n\n let sc_rollup_originate_case =\n make_manager_case\n Operation.Encoding.sc_rollup_originate_case\n Manager_result.sc_rollup_originate_case\n (function\n | Contents_and_result\n ( (Manager_operation {operation = Sc_rollup_originate _; _} as op),\n res ) ->\n Some (op, res)\n | _ -> None)\n\n let sc_rollup_add_messages_case =\n make_manager_case\n Operation.Encoding.sc_rollup_add_messages_case\n Manager_result.sc_rollup_add_messages_case\n (function\n | Contents_and_result\n ( (Manager_operation {operation = Sc_rollup_add_messages _; _} as op),\n res ) ->\n Some (op, res)\n | _ -> None)\n\n let sc_rollup_cement_case =\n make_manager_case\n Operation.Encoding.sc_rollup_cement_case\n Manager_result.sc_rollup_cement_case\n (function\n | Contents_and_result\n ((Manager_operation {operation = Sc_rollup_cement _; _} as op), res)\n ->\n Some (op, res)\n | _ -> None)\n\n let sc_rollup_publish_case =\n make_manager_case\n Operation.Encoding.sc_rollup_publish_case\n Manager_result.sc_rollup_publish_case\n (function\n | Contents_and_result\n ((Manager_operation {operation = Sc_rollup_publish _; _} as op), res)\n ->\n Some (op, res)\n | _ -> None)\n\n let sc_rollup_refute_case =\n make_manager_case\n Operation.Encoding.sc_rollup_refute_case\n Manager_result.sc_rollup_refute_case\n (function\n | Contents_and_result\n ((Manager_operation {operation = Sc_rollup_refute _; _} as op), res)\n ->\n Some (op, res)\n | _ -> None)\n\n let sc_rollup_timeout_case =\n make_manager_case\n Operation.Encoding.sc_rollup_timeout_case\n Manager_result.sc_rollup_timeout_case\n (function\n | Contents_and_result\n ((Manager_operation {operation = Sc_rollup_timeout _; _} as op), res)\n ->\n Some (op, res)\n | _ -> None)\n\n let sc_rollup_execute_outbox_message_case =\n make_manager_case\n Operation.Encoding.sc_rollup_execute_outbox_message_case\n Manager_result.sc_rollup_execute_outbox_message_case\n (function\n | Contents_and_result\n ( (Manager_operation\n {operation = Sc_rollup_execute_outbox_message _; _} as op),\n res ) ->\n Some (op, res)\n | _ -> None)\n\n let sc_rollup_recover_bond_case =\n make_manager_case\n Operation.Encoding.sc_rollup_recover_bond_case\n Manager_result.sc_rollup_recover_bond_case\n (function\n | Contents_and_result\n ( (Manager_operation {operation = Sc_rollup_recover_bond _; _} as op),\n res ) ->\n Some (op, res)\n | _ -> None)\n\n let zk_rollup_origination_case =\n make_manager_case\n Operation.Encoding.zk_rollup_origination_case\n Manager_result.zk_rollup_origination_case\n (function\n | Contents_and_result\n ( (Manager_operation {operation = Zk_rollup_origination _; _} as op),\n res ) ->\n Some (op, res)\n | _ -> None)\n\n let zk_rollup_publish_case =\n make_manager_case\n Operation.Encoding.zk_rollup_publish_case\n Manager_result.zk_rollup_publish_case\n (function\n | Contents_and_result\n ((Manager_operation {operation = Zk_rollup_publish _; _} as op), res)\n ->\n Some (op, res)\n | _ -> None)\n\n let zk_rollup_update_case =\n make_manager_case\n Operation.Encoding.zk_rollup_update_case\n Manager_result.zk_rollup_update_case\n (function\n | Contents_and_result\n ((Manager_operation {operation = Zk_rollup_update _; _} as op), res)\n ->\n Some (op, res)\n | _ -> None)\nend\n\nlet contents_result_encoding =\n let open Encoding in\n let make\n (Case\n {\n op_case = Operation.Encoding.Case {tag; name; _};\n encoding;\n mselect = _;\n select;\n proj;\n inj;\n }) =\n let proj x = match select x with None -> None | Some x -> Some (proj x) in\n let inj x = Contents_result (inj x) in\n tagged_case (Tag tag) name encoding proj inj\n in\n def \"operation.alpha.contents_result\"\n @@ union\n [\n make seed_nonce_revelation_case;\n make vdf_revelation_case;\n make endorsement_case;\n make preendorsement_case;\n make dal_attestation_case;\n make double_preendorsement_evidence_case;\n make double_endorsement_evidence_case;\n make double_baking_evidence_case;\n make activate_account_case;\n make proposals_case;\n make ballot_case;\n make drain_delegate_case;\n make reveal_case;\n make transaction_case;\n make origination_case;\n make delegation_case;\n make register_global_constant_case;\n make set_deposits_limit_case;\n make increase_paid_storage_case;\n make update_consensus_key_case;\n make tx_rollup_origination_case;\n make tx_rollup_submit_batch_case;\n make tx_rollup_commit_case;\n make tx_rollup_return_bond_case;\n make tx_rollup_finalize_commitment_case;\n make tx_rollup_remove_commitment_case;\n make tx_rollup_rejection_case;\n make tx_rollup_dispatch_tickets_case;\n make transfer_ticket_case;\n make dal_publish_slot_header_case;\n make sc_rollup_originate_case;\n make sc_rollup_add_messages_case;\n make sc_rollup_cement_case;\n make sc_rollup_publish_case;\n make sc_rollup_refute_case;\n make sc_rollup_timeout_case;\n make sc_rollup_execute_outbox_message_case;\n make sc_rollup_recover_bond_case;\n make zk_rollup_origination_case;\n make zk_rollup_publish_case;\n make zk_rollup_update_case;\n ]\n\nlet contents_and_result_encoding =\n let open Encoding in\n let make\n (Case\n {\n op_case = Operation.Encoding.Case {tag; name; encoding; proj; inj; _};\n mselect;\n encoding = meta_encoding;\n proj = meta_proj;\n inj = meta_inj;\n _;\n }) =\n let proj c =\n match mselect c with\n | Some (op, res) -> Some (proj op, meta_proj res)\n | _ -> None\n in\n let inj (op, res) = Contents_and_result (inj op, meta_inj res) in\n let encoding = merge_objs encoding (obj1 (req \"metadata\" meta_encoding)) in\n tagged_case (Tag tag) name encoding proj inj\n in\n def \"operation.alpha.operation_contents_and_result\"\n @@ union\n [\n make seed_nonce_revelation_case;\n make vdf_revelation_case;\n make endorsement_case;\n make preendorsement_case;\n make dal_attestation_case;\n make double_preendorsement_evidence_case;\n make double_endorsement_evidence_case;\n make double_baking_evidence_case;\n make activate_account_case;\n make proposals_case;\n make ballot_case;\n make reveal_case;\n make transaction_case;\n make origination_case;\n make delegation_case;\n make register_global_constant_case;\n make set_deposits_limit_case;\n make increase_paid_storage_case;\n make update_consensus_key_case;\n make drain_delegate_case;\n make tx_rollup_origination_case;\n make tx_rollup_submit_batch_case;\n make tx_rollup_commit_case;\n make tx_rollup_return_bond_case;\n make tx_rollup_finalize_commitment_case;\n make tx_rollup_remove_commitment_case;\n make tx_rollup_rejection_case;\n make transfer_ticket_case;\n make dal_publish_slot_header_case;\n make tx_rollup_dispatch_tickets_case;\n make sc_rollup_originate_case;\n make sc_rollup_add_messages_case;\n make sc_rollup_cement_case;\n make sc_rollup_publish_case;\n make sc_rollup_refute_case;\n make sc_rollup_timeout_case;\n make sc_rollup_execute_outbox_message_case;\n make sc_rollup_recover_bond_case;\n make zk_rollup_origination_case;\n make zk_rollup_publish_case;\n make zk_rollup_update_case;\n ]\n\ntype 'kind contents_result_list =\n | Single_result : 'kind contents_result -> 'kind contents_result_list\n | Cons_result :\n 'kind Kind.manager contents_result\n * 'rest Kind.manager contents_result_list\n -> ('kind * 'rest) Kind.manager contents_result_list\n\ntype packed_contents_result_list =\n | Contents_result_list :\n 'kind contents_result_list\n -> packed_contents_result_list\n\nlet contents_result_list_encoding =\n let rec to_list = function\n | Contents_result_list (Single_result o) -> [Contents_result o]\n | Contents_result_list (Cons_result (o, os)) ->\n Contents_result o :: to_list (Contents_result_list os)\n in\n let rec of_list = function\n | [] -> Error \"cannot decode empty operation result\"\n | [Contents_result o] -> Ok (Contents_result_list (Single_result o))\n | Contents_result o :: os -> (\n of_list os >>? fun (Contents_result_list os) ->\n match (o, os) with\n | Manager_operation_result _, Single_result (Manager_operation_result _)\n ->\n Ok (Contents_result_list (Cons_result (o, os)))\n | Manager_operation_result _, Cons_result _ ->\n Ok (Contents_result_list (Cons_result (o, os)))\n | _ -> Error \"cannot decode ill-formed operation result\")\n in\n def \"operation.alpha.contents_list_result\"\n @@ conv_with_guard to_list of_list (list contents_result_encoding)\n\ntype 'kind contents_and_result_list =\n | Single_and_result :\n 'kind Alpha_context.contents * 'kind contents_result\n -> 'kind contents_and_result_list\n | Cons_and_result :\n 'kind Kind.manager Alpha_context.contents\n * 'kind Kind.manager contents_result\n * 'rest Kind.manager contents_and_result_list\n -> ('kind * 'rest) Kind.manager contents_and_result_list\n\ntype packed_contents_and_result_list =\n | Contents_and_result_list :\n 'kind contents_and_result_list\n -> packed_contents_and_result_list\n\nlet contents_and_result_list_encoding =\n let rec to_list = function\n | Contents_and_result_list (Single_and_result (op, res)) ->\n [Contents_and_result (op, res)]\n | Contents_and_result_list (Cons_and_result (op, res, rest)) ->\n Contents_and_result (op, res) :: to_list (Contents_and_result_list rest)\n in\n let rec of_list = function\n | [] -> Error \"cannot decode empty combined operation result\"\n | [Contents_and_result (op, res)] ->\n Ok (Contents_and_result_list (Single_and_result (op, res)))\n | Contents_and_result (op, res) :: rest -> (\n of_list rest >>? fun (Contents_and_result_list rest) ->\n match (op, rest) with\n | Manager_operation _, Single_and_result (Manager_operation _, _) ->\n Ok (Contents_and_result_list (Cons_and_result (op, res, rest)))\n | Manager_operation _, Cons_and_result (_, _, _) ->\n Ok (Contents_and_result_list (Cons_and_result (op, res, rest)))\n | _ -> Error \"cannot decode ill-formed combined operation result\")\n in\n conv_with_guard to_list of_list (Variable.list contents_and_result_encoding)\n\ntype 'kind operation_metadata = {contents : 'kind contents_result_list}\n\ntype packed_operation_metadata =\n | Operation_metadata : 'kind operation_metadata -> packed_operation_metadata\n | No_operation_metadata : packed_operation_metadata\n\nlet operation_metadata_encoding =\n def \"operation.alpha.result\"\n @@ union\n [\n case\n (Tag 0)\n ~title:\"Operation_metadata\"\n contents_result_list_encoding\n (function\n | Operation_metadata {contents} ->\n Some (Contents_result_list contents)\n | _ -> None)\n (fun (Contents_result_list contents) ->\n Operation_metadata {contents});\n case\n (Tag 1)\n ~title:\"No_operation_metadata\"\n empty\n (function No_operation_metadata -> Some () | _ -> None)\n (fun () -> No_operation_metadata);\n ]\n\nlet kind_equal :\n type kind kind2.\n kind contents -> kind2 contents_result -> (kind, kind2) eq option =\n fun op res ->\n match (op, res) with\n | Endorsement _, Endorsement_result _ -> Some Eq\n | Endorsement _, _ -> None\n | Preendorsement _, Preendorsement_result _ -> Some Eq\n | Preendorsement _, _ -> None\n | Dal_attestation _, Dal_attestation_result _ -> Some Eq\n | Dal_attestation _, _ -> None\n | Seed_nonce_revelation _, Seed_nonce_revelation_result _ -> Some Eq\n | Seed_nonce_revelation _, _ -> None\n | Vdf_revelation _, Vdf_revelation_result _ -> Some Eq\n | Vdf_revelation _, _ -> None\n | Double_preendorsement_evidence _, Double_preendorsement_evidence_result _ ->\n Some Eq\n | Double_preendorsement_evidence _, _ -> None\n | Double_endorsement_evidence _, Double_endorsement_evidence_result _ ->\n Some Eq\n | Double_endorsement_evidence _, _ -> None\n | Double_baking_evidence _, Double_baking_evidence_result _ -> Some Eq\n | Double_baking_evidence _, _ -> None\n | Activate_account _, Activate_account_result _ -> Some Eq\n | Activate_account _, _ -> None\n | Proposals _, Proposals_result -> Some Eq\n | Proposals _, _ -> None\n | Ballot _, Ballot_result -> Some Eq\n | Ballot _, _ -> None\n | Drain_delegate _, Drain_delegate_result _ -> Some Eq\n | Drain_delegate _, _ -> None\n | Failing_noop _, _ ->\n (* the Failing_noop operation always fails and can't have result *)\n None\n | ( Manager_operation {operation = Reveal _; _},\n Manager_operation_result {operation_result = Applied (Reveal_result _); _}\n ) ->\n Some Eq\n | ( Manager_operation {operation = Reveal _; _},\n Manager_operation_result\n {operation_result = Backtracked (Reveal_result _, _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Reveal _; _},\n Manager_operation_result\n {\n operation_result = Failed (Alpha_context.Kind.Reveal_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Reveal _; _},\n Manager_operation_result\n {operation_result = Skipped Alpha_context.Kind.Reveal_manager_kind; _} )\n ->\n Some Eq\n | Manager_operation {operation = Reveal _; _}, _ -> None\n | ( Manager_operation {operation = Transaction _; _},\n Manager_operation_result\n {operation_result = Applied (Transaction_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Transaction _; _},\n Manager_operation_result\n {operation_result = Backtracked (Transaction_result _, _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Transaction _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Transaction_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Transaction _; _},\n Manager_operation_result\n {\n operation_result = Skipped Alpha_context.Kind.Transaction_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Transaction _; _}, _ -> None\n | ( Manager_operation {operation = Origination _; _},\n Manager_operation_result\n {operation_result = Applied (Origination_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Origination _; _},\n Manager_operation_result\n {operation_result = Backtracked (Origination_result _, _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Origination _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Origination_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Origination _; _},\n Manager_operation_result\n {\n operation_result = Skipped Alpha_context.Kind.Origination_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Origination _; _}, _ -> None\n | ( Manager_operation {operation = Delegation _; _},\n Manager_operation_result\n {operation_result = Applied (Delegation_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Delegation _; _},\n Manager_operation_result\n {operation_result = Backtracked (Delegation_result _, _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Delegation _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Delegation_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Delegation _; _},\n Manager_operation_result\n {\n operation_result = Skipped Alpha_context.Kind.Delegation_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Delegation _; _}, _ -> None\n | ( Manager_operation {operation = Update_consensus_key _; _},\n Manager_operation_result\n {operation_result = Applied (Update_consensus_key_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Update_consensus_key _; _},\n Manager_operation_result\n {operation_result = Backtracked (Update_consensus_key_result _, _); _} )\n ->\n Some Eq\n | ( Manager_operation {operation = Update_consensus_key _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Update_consensus_key_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Update_consensus_key _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Update_consensus_key_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Update_consensus_key _; _}, _ -> None\n | ( Manager_operation {operation = Register_global_constant _; _},\n Manager_operation_result\n {operation_result = Applied (Register_global_constant_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Register_global_constant _; _},\n Manager_operation_result\n {\n operation_result = Backtracked (Register_global_constant_result _, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Register_global_constant _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Register_global_constant_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Register_global_constant _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Register_global_constant_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Register_global_constant _; _}, _ -> None\n | ( Manager_operation {operation = Set_deposits_limit _; _},\n Manager_operation_result\n {operation_result = Applied (Set_deposits_limit_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Set_deposits_limit _; _},\n Manager_operation_result\n {operation_result = Backtracked (Set_deposits_limit_result _, _); _} )\n ->\n Some Eq\n | ( Manager_operation {operation = Set_deposits_limit _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Set_deposits_limit_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Set_deposits_limit _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Set_deposits_limit_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Set_deposits_limit _; _}, _ -> None\n | ( Manager_operation {operation = Increase_paid_storage _; _},\n Manager_operation_result\n {operation_result = Applied (Increase_paid_storage_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Increase_paid_storage _; _},\n Manager_operation_result\n {operation_result = Backtracked (Increase_paid_storage_result _, _); _}\n ) ->\n Some Eq\n | ( Manager_operation {operation = Increase_paid_storage _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Increase_paid_storage_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Increase_paid_storage _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Increase_paid_storage_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Increase_paid_storage _; _}, _ -> None\n | ( Manager_operation {operation = Tx_rollup_origination; _},\n Manager_operation_result\n {operation_result = Applied (Tx_rollup_origination_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_origination; _},\n Manager_operation_result\n {operation_result = Backtracked (Tx_rollup_origination_result _, _); _}\n ) ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_origination; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Tx_rollup_origination_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_origination; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Tx_rollup_origination_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Tx_rollup_origination; _}, _ -> None\n | ( Manager_operation {operation = Tx_rollup_submit_batch _; _},\n Manager_operation_result\n {operation_result = Applied (Tx_rollup_submit_batch_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_submit_batch _; _},\n Manager_operation_result\n {operation_result = Backtracked (Tx_rollup_submit_batch_result _, _); _}\n ) ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_submit_batch _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Tx_rollup_submit_batch_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_submit_batch _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Tx_rollup_submit_batch_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Tx_rollup_submit_batch _; _}, _ -> None\n | ( Manager_operation {operation = Tx_rollup_commit _; _},\n Manager_operation_result\n {operation_result = Applied (Tx_rollup_commit_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_commit _; _},\n Manager_operation_result\n {operation_result = Backtracked (Tx_rollup_commit_result _, _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_commit _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Tx_rollup_commit_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_commit _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Tx_rollup_commit_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Tx_rollup_commit _; _}, _ -> None\n | ( Manager_operation {operation = Tx_rollup_return_bond _; _},\n Manager_operation_result\n {operation_result = Applied (Tx_rollup_return_bond_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_return_bond _; _},\n Manager_operation_result\n {operation_result = Backtracked (Tx_rollup_return_bond_result _, _); _}\n ) ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_return_bond _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Tx_rollup_return_bond_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_return_bond _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Tx_rollup_return_bond_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Tx_rollup_return_bond _; _}, _ -> None\n | ( Manager_operation {operation = Sc_rollup_recover_bond _; _},\n Manager_operation_result\n {operation_result = Applied (Sc_rollup_recover_bond_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_recover_bond _; _},\n Manager_operation_result\n {operation_result = Backtracked (Sc_rollup_recover_bond_result _, _); _}\n ) ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_recover_bond _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Sc_rollup_recover_bond_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_recover_bond _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Sc_rollup_recover_bond_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Sc_rollup_recover_bond _; _}, _ -> None\n | ( Manager_operation {operation = Tx_rollup_finalize_commitment _; _},\n Manager_operation_result\n {operation_result = Applied (Tx_rollup_finalize_commitment_result _); _}\n ) ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_finalize_commitment _; _},\n Manager_operation_result\n {\n operation_result =\n Backtracked (Tx_rollup_finalize_commitment_result _, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_finalize_commitment _; _},\n Manager_operation_result\n {\n operation_result =\n Failed\n (Alpha_context.Kind.Tx_rollup_finalize_commitment_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_finalize_commitment _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped\n Alpha_context.Kind.Tx_rollup_finalize_commitment_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Tx_rollup_finalize_commitment _; _}, _ ->\n None\n | ( Manager_operation {operation = Tx_rollup_remove_commitment _; _},\n Manager_operation_result\n {operation_result = Applied (Tx_rollup_remove_commitment_result _); _} )\n ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_remove_commitment _; _},\n Manager_operation_result\n {\n operation_result =\n Backtracked (Tx_rollup_remove_commitment_result _, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_remove_commitment _; _},\n Manager_operation_result\n {\n operation_result =\n Failed\n (Alpha_context.Kind.Tx_rollup_remove_commitment_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_remove_commitment _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Tx_rollup_remove_commitment_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Tx_rollup_remove_commitment _; _}, _ -> None\n | ( Manager_operation {operation = Tx_rollup_rejection _; _},\n Manager_operation_result\n {operation_result = Applied (Tx_rollup_rejection_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_rejection _; _},\n Manager_operation_result\n {operation_result = Backtracked (Tx_rollup_rejection_result _, _); _} )\n ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_rejection _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Tx_rollup_rejection_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_rejection _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Tx_rollup_rejection_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Tx_rollup_rejection _; _}, _ -> None\n | ( Manager_operation {operation = Tx_rollup_dispatch_tickets _; _},\n Manager_operation_result\n {operation_result = Applied (Tx_rollup_dispatch_tickets_result _); _} )\n ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_dispatch_tickets _; _},\n Manager_operation_result\n {\n operation_result = Backtracked (Tx_rollup_dispatch_tickets_result _, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_dispatch_tickets _; _},\n Manager_operation_result\n {\n operation_result =\n Failed\n (Alpha_context.Kind.Tx_rollup_dispatch_tickets_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Tx_rollup_dispatch_tickets _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Tx_rollup_dispatch_tickets_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Tx_rollup_dispatch_tickets _; _}, _ -> None\n | ( Manager_operation {operation = Transfer_ticket _; _},\n Manager_operation_result\n {operation_result = Applied (Transfer_ticket_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Transfer_ticket _; _},\n Manager_operation_result\n {operation_result = Backtracked (Transfer_ticket_result _, _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Transfer_ticket _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Transfer_ticket_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Transfer_ticket _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Transfer_ticket_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Transfer_ticket _; _}, _ -> None\n | ( Manager_operation {operation = Dal_publish_slot_header _; _},\n Manager_operation_result\n {operation_result = Applied (Dal_publish_slot_header_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Dal_publish_slot_header _; _},\n Manager_operation_result\n {\n operation_result = Backtracked (Dal_publish_slot_header_result _, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Dal_publish_slot_header _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Dal_publish_slot_header_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Dal_publish_slot_header _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Dal_publish_slot_header_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Dal_publish_slot_header _; _}, _ -> None\n | ( Manager_operation {operation = Sc_rollup_originate _; _},\n Manager_operation_result\n {operation_result = Applied (Sc_rollup_originate_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_originate _; _},\n Manager_operation_result\n {operation_result = Backtracked (Sc_rollup_originate_result _, _); _} )\n ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_originate _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Sc_rollup_originate_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_originate _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Sc_rollup_originate_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Sc_rollup_originate _; _}, _ -> None\n | ( Manager_operation {operation = Sc_rollup_add_messages _; _},\n Manager_operation_result\n {operation_result = Applied (Sc_rollup_add_messages_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_add_messages _; _},\n Manager_operation_result\n {operation_result = Backtracked (Sc_rollup_add_messages_result _, _); _}\n ) ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_add_messages _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Sc_rollup_add_messages_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_add_messages _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Sc_rollup_add_messages_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Sc_rollup_add_messages _; _}, _ -> None\n | ( Manager_operation {operation = Sc_rollup_cement _; _},\n Manager_operation_result\n {operation_result = Applied (Sc_rollup_cement_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_cement _; _},\n Manager_operation_result\n {operation_result = Backtracked (Sc_rollup_cement_result _, _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_cement _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Sc_rollup_cement_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_cement _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Sc_rollup_cement_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Sc_rollup_cement _; _}, _ -> None\n | ( Manager_operation {operation = Sc_rollup_publish _; _},\n Manager_operation_result\n {operation_result = Applied (Sc_rollup_publish_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_publish _; _},\n Manager_operation_result\n {operation_result = Backtracked (Sc_rollup_publish_result _, _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_publish _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Sc_rollup_publish_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_publish _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Sc_rollup_publish_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Sc_rollup_publish _; _}, _ -> None\n | ( Manager_operation {operation = Sc_rollup_refute _; _},\n Manager_operation_result\n {operation_result = Applied (Sc_rollup_refute_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_refute _; _},\n Manager_operation_result\n {operation_result = Backtracked (Sc_rollup_refute_result _, _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_refute _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Sc_rollup_refute_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_refute _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Sc_rollup_refute_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Sc_rollup_refute _; _}, _ -> None\n | ( Manager_operation {operation = Sc_rollup_timeout _; _},\n Manager_operation_result\n {operation_result = Applied (Sc_rollup_timeout_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_timeout _; _},\n Manager_operation_result\n {operation_result = Backtracked (Sc_rollup_timeout_result _, _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_timeout _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Sc_rollup_timeout_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_timeout _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Sc_rollup_timeout_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Sc_rollup_timeout _; _}, _ -> None\n | ( Manager_operation {operation = Sc_rollup_execute_outbox_message _; _},\n Manager_operation_result\n {\n operation_result = Applied (Sc_rollup_execute_outbox_message_result _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_execute_outbox_message _; _},\n Manager_operation_result\n {\n operation_result =\n Backtracked (Sc_rollup_execute_outbox_message_result _, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_execute_outbox_message _; _},\n Manager_operation_result\n {\n operation_result =\n Failed\n ( Alpha_context.Kind.Sc_rollup_execute_outbox_message_manager_kind,\n _ );\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Sc_rollup_execute_outbox_message _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped\n Alpha_context.Kind.Sc_rollup_execute_outbox_message_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Sc_rollup_execute_outbox_message _; _}, _ ->\n None\n | ( Manager_operation {operation = Zk_rollup_origination _; _},\n Manager_operation_result\n {operation_result = Applied (Zk_rollup_origination_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Zk_rollup_origination _; _},\n Manager_operation_result\n {operation_result = Backtracked (Zk_rollup_origination_result _, _); _}\n ) ->\n Some Eq\n | ( Manager_operation {operation = Zk_rollup_origination _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Zk_rollup_origination_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Zk_rollup_origination _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Zk_rollup_origination_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Zk_rollup_origination _; _}, _ -> None\n | ( Manager_operation {operation = Zk_rollup_publish _; _},\n Manager_operation_result\n {operation_result = Applied (Zk_rollup_publish_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Zk_rollup_publish _; _},\n Manager_operation_result\n {operation_result = Backtracked (Zk_rollup_publish_result _, _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Zk_rollup_publish _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Zk_rollup_publish_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Zk_rollup_publish _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Zk_rollup_publish_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Zk_rollup_publish _; _}, _ -> None\n | ( Manager_operation {operation = Zk_rollup_update _; _},\n Manager_operation_result\n {operation_result = Applied (Zk_rollup_update_result _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Zk_rollup_update _; _},\n Manager_operation_result\n {operation_result = Backtracked (Zk_rollup_update_result _, _); _} ) ->\n Some Eq\n | ( Manager_operation {operation = Zk_rollup_update _; _},\n Manager_operation_result\n {\n operation_result =\n Failed (Alpha_context.Kind.Zk_rollup_update_manager_kind, _);\n _;\n } ) ->\n Some Eq\n | ( Manager_operation {operation = Zk_rollup_update _; _},\n Manager_operation_result\n {\n operation_result =\n Skipped Alpha_context.Kind.Zk_rollup_update_manager_kind;\n _;\n } ) ->\n Some Eq\n | Manager_operation {operation = Zk_rollup_update _; _}, _ -> None\n\nlet rec kind_equal_list :\n type kind kind2.\n kind contents_list -> kind2 contents_result_list -> (kind, kind2) eq option\n =\n fun contents res ->\n match (contents, res) with\n | Single op, Single_result res -> (\n match kind_equal op res with None -> None | Some Eq -> Some Eq)\n | Cons (op, ops), Cons_result (res, ress) -> (\n match kind_equal op res with\n | None -> None\n | Some Eq -> (\n match kind_equal_list ops ress with\n | None -> None\n | Some Eq -> Some Eq))\n | _ -> None\n\nlet rec pack_contents_list :\n type kind.\n kind contents_list ->\n kind contents_result_list ->\n kind contents_and_result_list =\n fun contents res ->\n match (contents, res) with\n | Single op, Single_result res -> Single_and_result (op, res)\n | Cons (op, ops), Cons_result (res, ress) ->\n Cons_and_result (op, res, pack_contents_list ops ress)\n | ( Single (Manager_operation _),\n Cons_result (Manager_operation_result _, Single_result _) ) ->\n .\n | ( Cons (_, _),\n Single_result (Manager_operation_result {operation_result = Failed _; _})\n ) ->\n .\n | ( Cons (_, _),\n Single_result (Manager_operation_result {operation_result = Skipped _; _})\n ) ->\n .\n | ( Cons (_, _),\n Single_result (Manager_operation_result {operation_result = Applied _; _})\n ) ->\n .\n | ( Cons (_, _),\n Single_result\n (Manager_operation_result {operation_result = Backtracked _; _}) ) ->\n .\n | Single _, Cons_result _ -> .\n\nlet rec unpack_contents_list :\n type kind.\n kind contents_and_result_list ->\n kind contents_list * kind contents_result_list = function\n | Single_and_result (op, res) -> (Single op, Single_result res)\n | Cons_and_result (op, res, rest) ->\n let ops, ress = unpack_contents_list rest in\n (Cons (op, ops), Cons_result (res, ress))\n\nlet rec to_list = function\n | Contents_result_list (Single_result o) -> [Contents_result o]\n | Contents_result_list (Cons_result (o, os)) ->\n Contents_result o :: to_list (Contents_result_list os)\n\nlet operation_data_and_metadata_encoding =\n def \"operation.alpha.operation_with_metadata\"\n @@ union\n [\n case\n (Tag 0)\n ~title:\"Operation_with_metadata\"\n (obj2\n (req \"contents\" (dynamic_size contents_and_result_list_encoding))\n (opt \"signature\" Signature.encoding))\n (function\n | Operation_data _, No_operation_metadata -> None\n | Operation_data op, Operation_metadata res -> (\n match kind_equal_list op.contents res.contents with\n | None ->\n Pervasives.failwith\n \"cannot decode inconsistent combined operation result\"\n | Some Eq ->\n Some\n ( Contents_and_result_list\n (pack_contents_list op.contents res.contents),\n op.signature )))\n (fun (Contents_and_result_list contents, signature) ->\n let op_contents, res_contents = unpack_contents_list contents in\n ( Operation_data {contents = op_contents; signature},\n Operation_metadata {contents = res_contents} ));\n case\n (Tag 1)\n ~title:\"Operation_without_metadata\"\n (obj2\n (req \"contents\" (dynamic_size Operation.contents_list_encoding))\n (opt \"signature\" Signature.encoding))\n (function\n | Operation_data op, No_operation_metadata ->\n Some (Contents_list op.contents, op.signature)\n | Operation_data _, Operation_metadata _ -> None)\n (fun (Contents_list contents, signature) ->\n (Operation_data {contents; signature}, No_operation_metadata));\n ]\n\ntype block_metadata = {\n proposer : Consensus_key.t;\n baker : Consensus_key.t;\n level_info : Level.t;\n voting_period_info : Voting_period.info;\n nonce_hash : Nonce_hash.t option;\n consumed_gas : Gas.Arith.fp;\n deactivated : Signature.Public_key_hash.t list;\n balance_updates : Receipt.balance_updates;\n liquidity_baking_toggle_ema : Liquidity_baking.Toggle_EMA.t;\n implicit_operations_results : packed_successful_manager_operation_result list;\n dal_attestation : Dal.Attestation.t option;\n}\n\nlet block_metadata_encoding =\n let open Data_encoding in\n def \"block_header.alpha.metadata\"\n @@ conv\n (fun {\n proposer =\n {delegate = proposer; consensus_pkh = proposer_active_key};\n baker = {delegate = baker; consensus_pkh = baker_active_key};\n level_info;\n voting_period_info;\n nonce_hash;\n consumed_gas;\n deactivated;\n balance_updates;\n liquidity_baking_toggle_ema;\n implicit_operations_results;\n dal_attestation;\n } ->\n ( ( proposer,\n baker,\n level_info,\n voting_period_info,\n nonce_hash,\n deactivated,\n balance_updates,\n liquidity_baking_toggle_ema,\n implicit_operations_results ),\n (proposer_active_key, baker_active_key, consumed_gas, dal_attestation)\n ))\n (fun ( ( proposer,\n baker,\n level_info,\n voting_period_info,\n nonce_hash,\n deactivated,\n balance_updates,\n liquidity_baking_toggle_ema,\n implicit_operations_results ),\n ( proposer_active_key,\n baker_active_key,\n consumed_gas,\n dal_attestation ) ) ->\n {\n proposer = {delegate = proposer; consensus_pkh = proposer_active_key};\n baker = {delegate = baker; consensus_pkh = baker_active_key};\n level_info;\n voting_period_info;\n nonce_hash;\n consumed_gas;\n deactivated;\n balance_updates;\n liquidity_baking_toggle_ema;\n implicit_operations_results;\n dal_attestation;\n })\n (merge_objs\n (obj9\n (req \"proposer\" Signature.Public_key_hash.encoding)\n (req \"baker\" Signature.Public_key_hash.encoding)\n (req \"level_info\" Level.encoding)\n (req \"voting_period_info\" Voting_period.info_encoding)\n (req \"nonce_hash\" (option Nonce_hash.encoding))\n (req \"deactivated\" (list Signature.Public_key_hash.encoding))\n (dft \"balance_updates\" Receipt.balance_updates_encoding [])\n (req\n \"liquidity_baking_toggle_ema\"\n Liquidity_baking.Toggle_EMA.encoding)\n (req\n \"implicit_operations_results\"\n (list successful_manager_operation_result_encoding)))\n (obj4\n (req \"proposer_consensus_key\" Signature.Public_key_hash.encoding)\n (req \"baker_consensus_key\" Signature.Public_key_hash.encoding)\n (req \"consumed_milligas\" Gas.Arith.n_fp_encoding)\n (* DAL/FIXME https://gitlab.com/tezos/tezos/-/issues/3119\n This varopt is here while the DAL is behind a feature\n flag. This should be replaced by a required field once\n the feature flag will be activated. *)\n (varopt \"dal_attestation\" Dal.Attestation.encoding)))\n" ;
} ;
{ name = "Script_ir_translator_config" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\n(** [type_logger] is a function, whose task is to log how a stack's type\n is altered by some operation being logged. *)\ntype type_logger =\n Script.location ->\n stack_ty_before:Script.expr list ->\n stack_ty_after:Script.expr list ->\n unit\n\n(** LEGACY MODE is the feature of the Translator and Interpreter which\n allows us to distinguish between scripts already originated on chain\n and new ones.\n\n The reason to treat those types of scripts differently is the evolving\n nature of Michelson, which sometimes requires disabling features\n available in previous versions. These features must be supported at all\n times for already originated contracts, but we still want to disable\n them at least for new contracts.\n\n This distinction gives us a handy deprecation mechanism, which\n allows us to make sure that from a certain point on no more\n contract will be originated using these deprecated features. When\n that point time is reached, it becomes possible to patch existing\n contracts so that they no longer use the feature and remove it\n entirely.\n\n As a side effect, legacy mode can also be used to skip checks that\n have already been performed and hence are guaranteed to pass.*)\n\n(** [elab_config] is a record grouping together some flags and options\n shared by many of the functions in [Script_ir_translator]. It's\n convenient to group them together, because they're of similar\n types ([bool] or ['a option]), so they're easier not to mix together.\n It also makes for shorter and more readable function calls. *)\ntype elab_config = {\n type_logger : type_logger option;\n (** A function responsible for logging stack types during typechecking.\n Used especially in plugins for editors and IDEs. *)\n keep_extra_types_for_interpreter_logging : bool;\n (** If set to [true], it instructs the elaborator to retain some\n additional type information necessary for logging. This should\n never be enabled during validation to save memory occupied by\n cached contracts.\n\n NOTE: if this option wasn't passed to the elaborator and the \n interpreter was still called with logging enabled, it might\n result in a crash. This cannot be helped at the moment, but since \n logging is never enabled during validation, we should be safe. *)\n legacy : bool; (** If set to true, it enables the legacy mode (see above). *)\n}\n\n(** [make ?type_logger ?logging_enabled ~legacy ()] creates an [elab_config]\n record to be passed to parsing functions in [Script_ir_translator].\n\n Note: [?logging_enabled] defaults to [false], because it only ever should\n be set to [true] if the Translator is called from outside the protocol\n (i.e. from the Plugin). *)\nlet make :\n ?type_logger:type_logger ->\n ?keep_extra_types_for_interpreter_logging:bool ->\n legacy:bool ->\n unit ->\n elab_config =\n fun ?type_logger ?(keep_extra_types_for_interpreter_logging = false) ~legacy () ->\n {type_logger; keep_extra_types_for_interpreter_logging; legacy}\n" ;
} ;
{ name = "Script_ir_unparser" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\nopen Script_typed_ir\n\n(** Flag that drives unparsing of typed values to nodes.\n - [Optimized_legacy] must be kept backward-compatible in order to compute\n valid hashes (of big map keys).\n - [Optimized] may be used as long as the result can be read by {!Script_translator.parse_data}.\n - [Readable] produces with [string] values instead of [bytes] when feasible.\n*)\ntype unparsing_mode = Optimized | Readable | Optimized_legacy\n\n(** [('t, 'd) comb_witness] describes types of values belonging to a [comb]\n of type ['t] and size ['d]. *)\ntype ('ty, 'depth) comb_witness =\n | Comb_Pair : ('t, 'd) comb_witness -> (_ * 't, unit -> 'd) comb_witness\n | Comb_Any : (_, _) comb_witness\n\n(** [serialize_ty_for_error ty] returns the Micheline representation of [ty]\n suitable for rendering in an error message. Does not consume gas, since\n when this function is called, the operation must have already failed. *)\nval serialize_ty_for_error : ('a, 'b) ty -> Script.expr\n\n(** [serialize_stack_for_error ctxt stack_ty] returns a Micheline representation of\n [stack_ty] as a list of Micheline expressions ONLY IF gas is unlimited\n in [ctxt]. Otherwise returns an empty list. *)\nval serialize_stack_for_error : context -> ('a, 'b) stack_ty -> Script.expr list\n\n(** [unparse_ty ~loc ctxt ty] returns the Micheline representation of a given\n type and an update context, where gas has been properly consumed. *)\nval unparse_ty :\n loc:'loc ->\n context ->\n ('b, 'c) ty ->\n ('loc Script.michelson_node * context, error trace) result\n\n(** [unparse_comparable_ty_uncarbonated ~loc ty] returns the Michelson\n representation of comparable type [ty] without consuming gas. *)\nval unparse_comparable_ty_uncarbonated :\n loc:'loc -> 'a comparable_ty -> 'loc Script.michelson_node\n\n(** [unparse_stack_uncarbonated stack_ty] returns the Micheline representation\n of [stack_ty]. Does not consume gas. *)\nval unparse_stack_uncarbonated : ('a, 's) stack_ty -> Script.expr list\n\n(** [unparse_parameter_ty ~loc ctxt ty ~entrypoints] is a specialised version of\n [unparse_ty], which also analyses [entrypoints] in order to annotate\n the returned type with adequate annotations. *)\nval unparse_parameter_ty :\n loc:'loc ->\n context ->\n ('a, 'c) ty ->\n entrypoints:'a entrypoints ->\n ('loc Script.michelson_node * context, error trace) result\n\n(** [unparse_bls12_381_g1 ~loc ctxt bls] returns the Micheline representation\n of [bls] and consumes gas from [ctxt]. *)\nval unparse_bls12_381_g1 :\n loc:'loc ->\n context ->\n Script_bls.G1.t ->\n ('loc Script.michelson_node * context, error trace) result\n\n(** [unparse_bls12_381_g1 ~loc ctxt bls] returns the Micheline representation\n of [bls] and consumes gas from [ctxt]. *)\nval unparse_bls12_381_g2 :\n loc:'loc ->\n context ->\n Script_bls.G2.t ->\n ('loc Script.michelson_node * context, error trace) result\n\n(** [unparse_bls12_381_g1 ~loc ctxt bls] returns the Micheline representation\n of [bls] and consumes gas from [ctxt]. *)\nval unparse_bls12_381_fr :\n loc:'loc ->\n context ->\n Script_bls.Fr.t ->\n ('loc Script.michelson_node * context, error trace) result\n\n(** [unparse_operation ~loc ctxt op] returns the Micheline representation of\n [op] and consumes gas from [ctxt]. Useful only for producing execution\n traces in the interpreter. *)\nval unparse_operation :\n loc:'loc ->\n context ->\n Script_typed_ir.operation ->\n ('loc Script.michelson_node * context, error trace) result\n\n(** [unparse_with_data_encoding ~loc ctxt v gas_cost enc] returns the bytes\n representation of [v] wrapped in [Micheline.Bytes], consuming [gas_cost]\n from [ctxt]. *)\nval unparse_with_data_encoding :\n loc:'loc ->\n context ->\n 'a ->\n Gas.cost ->\n 'a Data_encoding.t ->\n ('loc Script.michelson_node * context, error trace) result Lwt.t\n\n(** [unparse_comparable_data ctxt unparsing_mode ty v] returns the\n Micheline representation of [v] of type [ty], consuming gas from\n [ctxt]. *)\nval unparse_comparable_data :\n context ->\n unparsing_mode ->\n 'a comparable_ty ->\n 'a ->\n (Script.expr * context) tzresult Lwt.t\n\n(** [unparse_contract ~loc ctxt unparsin_mode contract] returns a Micheline\n representation of a given contract in a given [unparsing_mode]. Consumes\n gas [ctxt]. *)\nval unparse_contract :\n loc:'loc ->\n context ->\n unparsing_mode ->\n 'b typed_contract ->\n ('loc Script.michelson_node * context, error trace) result\n\n(** Lambdas are normalized at parsing and also at unparsing. These\n normalizations require to parse and unparse data appearing inside\n PUSH and introduces a mutual dependency between this module and\n [Script_ir_translator] which is resolved as follows:\n - [Script_ir_translator.parse_data] takes the normalization function\n [unparse_code_rec] as argument,\n - the unparsing function [unparse_data_rec] and the normalization\n function [unparse_code_rec] are mutually defined in a functor\n parameterized by the missing bits from [Script_ir_translator]; see the\n module signature [MICHELSON_PARSER] below.\n *)\n\n(** The [unparse_code_rec] function is not exported (except through\n the [Internal_for_benchmarking] module), but needs to be called by\n [parse_data] to normalize lambdas so it is passed as argument to\n the [parse_data] of the [MICHELSON_PARSER] signature below and to\n several functions of [Script_ir_translator]. To avoid repeating the\n signature of this function we define a type alias for it. *)\ntype unparse_code_rec =\n context ->\n stack_depth:int ->\n unparsing_mode ->\n Script.node ->\n (Script.node * context) tzresult Lwt.t\n\n(** [MICHELSON_PARSER] signature describes a set of dependencies required to\n unparse arbitrary values in the IR. Because some of those values contain\n just a Michelson code that does not need to be parsed immediately,\n unparsing them requires extracting information from that code \226\128\147 that's\n why we depend on the parser here. *)\n\nmodule type MICHELSON_PARSER = sig\n val opened_ticket_type :\n Script.location ->\n 'a comparable_ty ->\n (address, ('a, Script_int.n Script_int.num) pair) pair comparable_ty\n tzresult\n\n val parse_packable_ty :\n context ->\n stack_depth:int ->\n legacy:bool ->\n Script.node ->\n (ex_ty * context) tzresult\n\n val parse_data :\n unparse_code_rec:unparse_code_rec ->\n elab_conf:Script_ir_translator_config.elab_config ->\n stack_depth:int ->\n context ->\n allow_forged:bool ->\n ('a, 'ac) ty ->\n Script.node ->\n ('a * t) tzresult Lwt.t\nend\n\nmodule Data_unparser : functor (P : MICHELSON_PARSER) -> sig\n (** [unparse_data ctxt ~stack_depth unparsing_mode ty data] returns the\n Micheline representation of [data] of type [ty], consuming an appropriate\n amount of gas from [ctxt]. *)\n val unparse_data :\n context ->\n stack_depth:int ->\n unparsing_mode ->\n ('a, 'ac) ty ->\n 'a ->\n (Script.expr * context) tzresult Lwt.t\n\n (** [unparse_items ctxt ~stack_depth unparsing_mode kty vty assoc] returns the\n Micheline representation of [assoc] (being an association list) with keys\n of type [kty] and values of type [vty]. Gas is being consumed from\n [ctxt]. *)\n val unparse_items :\n context ->\n stack_depth:int ->\n unparsing_mode ->\n 'k comparable_ty ->\n ('v, 'vc) ty ->\n ('k * 'v) list ->\n (Script.expr list * context) tzresult Lwt.t\n\n (** [unparse_code ctxt ~stack_depth unparsing_mode code] returns [code]\n with [I_PUSH] instructions parsed and unparsed back to make sure that\n only forgeable values are being pushed. The gas is being consumed from\n [ctxt]. *)\n val unparse_code :\n context ->\n stack_depth:int ->\n unparsing_mode ->\n Script.node ->\n (Script.expr * context, error trace) result Lwt.t\n\n (** For benchmarking purpose, we also export versions of the unparsing\n functions which don't call location stripping. These functions are\n not carbonated and should not be called directly from the protocol. *)\n module Internal_for_benchmarking : sig\n val unparse_data :\n context ->\n stack_depth:int ->\n unparsing_mode ->\n ('a, 'ac) ty ->\n 'a ->\n (Script.node * context) tzresult Lwt.t\n\n val unparse_code :\n context ->\n stack_depth:int ->\n unparsing_mode ->\n Script.node ->\n (Script.node * context) tzresult Lwt.t\n end\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\nopen Micheline\nopen Script_typed_ir\nopen Michelson_v1_primitives\nmodule Unparse_costs = Michelson_v1_gas.Cost_of.Unparsing\n\ntype unparsing_mode = Optimized | Readable | Optimized_legacy\n\n(* This part contains the unparsing that does not depend on parsing\n (everything that cannot contain a lambda). The rest is located at\n the end of the file. *)\n\nlet unparse_memo_size ~loc memo_size =\n let z = Sapling.Memo_size.unparse_to_z memo_size in\n Int (loc, z)\n\nlet rec unparse_ty_and_entrypoints_uncarbonated :\n type a ac loc.\n loc:loc -> (a, ac) ty -> a entrypoints_node -> loc Script.michelson_node =\n fun ~loc ty {nested = nested_entrypoints; at_node} ->\n let name, args =\n match ty with\n | Unit_t -> (T_unit, [])\n | Int_t -> (T_int, [])\n | Nat_t -> (T_nat, [])\n | Signature_t -> (T_signature, [])\n | String_t -> (T_string, [])\n | Bytes_t -> (T_bytes, [])\n | Mutez_t -> (T_mutez, [])\n | Bool_t -> (T_bool, [])\n | Key_hash_t -> (T_key_hash, [])\n | Key_t -> (T_key, [])\n | Timestamp_t -> (T_timestamp, [])\n | Address_t -> (T_address, [])\n | Tx_rollup_l2_address_t -> (T_tx_rollup_l2_address, [])\n | Operation_t -> (T_operation, [])\n | Chain_id_t -> (T_chain_id, [])\n | Never_t -> (T_never, [])\n | Bls12_381_g1_t -> (T_bls12_381_g1, [])\n | Bls12_381_g2_t -> (T_bls12_381_g2, [])\n | Bls12_381_fr_t -> (T_bls12_381_fr, [])\n | Contract_t (ut, _meta) ->\n let t =\n unparse_ty_and_entrypoints_uncarbonated ~loc ut no_entrypoints\n in\n (T_contract, [t])\n | Pair_t (utl, utr, _meta, _) -> (\n let tl =\n unparse_ty_and_entrypoints_uncarbonated ~loc utl no_entrypoints\n in\n let tr =\n unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints\n in\n (* Fold [pair a1 (pair ... (pair an-1 an))] into [pair a1 ... an] *)\n (* Note that the folding does not happen if the pair on the right has an\n annotation because this annotation would be lost *)\n match tr with\n | Prim (_, T_pair, ts, []) -> (T_pair, tl :: ts)\n | _ -> (T_pair, [tl; tr]))\n | Union_t (utl, utr, _meta, _) ->\n let entrypoints_l, entrypoints_r =\n match nested_entrypoints with\n | Entrypoints_None -> (no_entrypoints, no_entrypoints)\n | Entrypoints_Union {left; right} -> (left, right)\n in\n let tl =\n unparse_ty_and_entrypoints_uncarbonated ~loc utl entrypoints_l\n in\n let tr =\n unparse_ty_and_entrypoints_uncarbonated ~loc utr entrypoints_r\n in\n (T_or, [tl; tr])\n | Lambda_t (uta, utr, _meta) ->\n let ta =\n unparse_ty_and_entrypoints_uncarbonated ~loc uta no_entrypoints\n in\n let tr =\n unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints\n in\n (T_lambda, [ta; tr])\n | Option_t (ut, _meta, _) ->\n let ut =\n unparse_ty_and_entrypoints_uncarbonated ~loc ut no_entrypoints\n in\n (T_option, [ut])\n | List_t (ut, _meta) ->\n let t =\n unparse_ty_and_entrypoints_uncarbonated ~loc ut no_entrypoints\n in\n (T_list, [t])\n | Ticket_t (ut, _meta) ->\n let t = unparse_comparable_ty_uncarbonated ~loc ut in\n (T_ticket, [t])\n | Set_t (ut, _meta) ->\n let t = unparse_comparable_ty_uncarbonated ~loc ut in\n (T_set, [t])\n | Map_t (uta, utr, _meta) ->\n let ta = unparse_comparable_ty_uncarbonated ~loc uta in\n let tr =\n unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints\n in\n (T_map, [ta; tr])\n | Big_map_t (uta, utr, _meta) ->\n let ta = unparse_comparable_ty_uncarbonated ~loc uta in\n let tr =\n unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints\n in\n (T_big_map, [ta; tr])\n | Sapling_transaction_t memo_size ->\n (T_sapling_transaction, [unparse_memo_size ~loc memo_size])\n | Sapling_transaction_deprecated_t memo_size ->\n (T_sapling_transaction_deprecated, [unparse_memo_size ~loc memo_size])\n | Sapling_state_t memo_size ->\n (T_sapling_state, [unparse_memo_size ~loc memo_size])\n | Chest_key_t -> (T_chest_key, [])\n | Chest_t -> (T_chest, [])\n in\n let annot =\n match at_node with\n | None -> []\n | Some {name; original_type_expr = _} ->\n [Entrypoint.unparse_as_field_annot name]\n in\n Prim (loc, name, args, annot)\n\nand unparse_comparable_ty_uncarbonated :\n type a loc. loc:loc -> a comparable_ty -> loc Script.michelson_node =\n fun ~loc ty -> unparse_ty_and_entrypoints_uncarbonated ~loc ty no_entrypoints\n\nlet unparse_ty_uncarbonated ~loc ty =\n unparse_ty_and_entrypoints_uncarbonated ~loc ty no_entrypoints\n\nlet unparse_ty ~loc ctxt ty =\n Gas.consume ctxt (Unparse_costs.unparse_type ty) >|? fun ctxt ->\n (unparse_ty_uncarbonated ~loc ty, ctxt)\n\nlet unparse_parameter_ty ~loc ctxt ty ~entrypoints =\n Gas.consume ctxt (Unparse_costs.unparse_type ty) >|? fun ctxt ->\n (unparse_ty_and_entrypoints_uncarbonated ~loc ty entrypoints.root, ctxt)\n\nlet serialize_ty_for_error ty =\n (*\n Types are bounded by [Constants.michelson_maximum_type_size], so\n [unparse_ty_uncarbonated] and [strip_locations] are bounded in time.\n\n It is hence OK to use them in errors that are not caught in the validation\n (only once in apply).\n *)\n unparse_ty_uncarbonated ~loc:() ty |> Micheline.strip_locations\n\nlet rec unparse_stack_uncarbonated :\n type a s. (a, s) stack_ty -> Script.expr list = function\n | Bot_t -> []\n | Item_t (ty, rest) ->\n let uty = unparse_ty_uncarbonated ~loc:() ty in\n let urest = unparse_stack_uncarbonated rest in\n strip_locations uty :: urest\n\nlet serialize_stack_for_error ctxt stack_ty =\n match Gas.level ctxt with\n | Unaccounted -> unparse_stack_uncarbonated stack_ty\n | Limited _ -> []\n\nlet unparse_unit ~loc ctxt () = ok (Prim (loc, D_Unit, [], []), ctxt)\n\nlet unparse_int ~loc ctxt v = ok (Int (loc, Script_int.to_zint v), ctxt)\n\nlet unparse_nat ~loc ctxt v = ok (Int (loc, Script_int.to_zint v), ctxt)\n\nlet unparse_string ~loc ctxt s =\n ok (String (loc, Script_string.to_string s), ctxt)\n\nlet unparse_bytes ~loc ctxt s = ok (Bytes (loc, s), ctxt)\n\nlet unparse_bool ~loc ctxt b =\n ok (Prim (loc, (if b then D_True else D_False), [], []), ctxt)\n\nlet unparse_timestamp ~loc ctxt mode t =\n match mode with\n | Optimized | Optimized_legacy ->\n ok (Int (loc, Script_timestamp.to_zint t), ctxt)\n | Readable -> (\n Gas.consume ctxt Unparse_costs.timestamp_readable >>? fun ctxt ->\n match Script_timestamp.to_notation t with\n | None -> ok (Int (loc, Script_timestamp.to_zint t), ctxt)\n | Some s -> ok (String (loc, s), ctxt))\n\nlet unparse_address ~loc ctxt mode {destination; entrypoint} =\n match mode with\n | Optimized | Optimized_legacy ->\n Gas.consume ctxt Unparse_costs.contract_optimized >|? fun ctxt ->\n let bytes =\n Data_encoding.Binary.to_bytes_exn\n Data_encoding.(tup2 Destination.encoding Entrypoint.value_encoding)\n (destination, entrypoint)\n in\n (Bytes (loc, bytes), ctxt)\n | Readable ->\n Gas.consume ctxt Unparse_costs.contract_readable >|? fun ctxt ->\n let notation =\n Destination.to_b58check destination\n ^ Entrypoint.to_address_suffix entrypoint\n in\n (String (loc, notation), ctxt)\n\nlet unparse_tx_rollup_l2_address ~loc ctxt mode\n (tx_address : tx_rollup_l2_address) =\n let tx_address = Indexable.to_value tx_address in\n match mode with\n | Optimized | Optimized_legacy ->\n Gas.consume ctxt Unparse_costs.contract_optimized >|? fun ctxt ->\n let bytes =\n Data_encoding.Binary.to_bytes_exn\n Tx_rollup_l2_address.encoding\n tx_address\n in\n (Bytes (loc, bytes), ctxt)\n | Readable ->\n Gas.consume ctxt Unparse_costs.contract_readable >|? fun ctxt ->\n let b58check = Tx_rollup_l2_address.to_b58check tx_address in\n (String (loc, b58check), ctxt)\n\nlet unparse_contract ~loc ctxt mode typed_contract =\n let destination = Typed_contract.destination typed_contract in\n let entrypoint = Typed_contract.entrypoint typed_contract in\n let address = {destination; entrypoint} in\n unparse_address ~loc ctxt mode address\n\nlet unparse_signature ~loc ctxt mode s =\n let s = Script_signature.get s in\n match mode with\n | Optimized | Optimized_legacy ->\n Gas.consume ctxt Unparse_costs.signature_optimized >|? fun ctxt ->\n let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in\n (Bytes (loc, bytes), ctxt)\n | Readable ->\n Gas.consume ctxt Unparse_costs.signature_readable >|? fun ctxt ->\n (String (loc, Signature.to_b58check s), ctxt)\n\nlet unparse_mutez ~loc ctxt v = ok (Int (loc, Z.of_int64 (Tez.to_mutez v)), ctxt)\n\nlet unparse_key ~loc ctxt mode k =\n match mode with\n | Optimized | Optimized_legacy ->\n Gas.consume ctxt Unparse_costs.public_key_optimized >|? fun ctxt ->\n let bytes =\n Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k\n in\n (Bytes (loc, bytes), ctxt)\n | Readable ->\n Gas.consume ctxt Unparse_costs.public_key_readable >|? fun ctxt ->\n (String (loc, Signature.Public_key.to_b58check k), ctxt)\n\nlet unparse_key_hash ~loc ctxt mode k =\n match mode with\n | Optimized | Optimized_legacy ->\n Gas.consume ctxt Unparse_costs.key_hash_optimized >|? fun ctxt ->\n let bytes =\n Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k\n in\n (Bytes (loc, bytes), ctxt)\n | Readable ->\n Gas.consume ctxt Unparse_costs.key_hash_readable >|? fun ctxt ->\n (String (loc, Signature.Public_key_hash.to_b58check k), ctxt)\n\n(* Operations are only unparsed during the production of execution traces of\n the interpreter. *)\nlet unparse_operation ~loc ctxt {piop; lazy_storage_diff = _} =\n let iop = Apply_internal_results.packed_internal_operation piop in\n let bytes =\n Data_encoding.Binary.to_bytes_exn\n Apply_internal_results.internal_operation_encoding\n iop\n in\n Gas.consume ctxt (Unparse_costs.operation bytes) >|? fun ctxt ->\n (Bytes (loc, bytes), ctxt)\n\nlet unparse_chain_id ~loc ctxt mode chain_id =\n match mode with\n | Optimized | Optimized_legacy ->\n Gas.consume ctxt Unparse_costs.chain_id_optimized >|? fun ctxt ->\n let bytes =\n Data_encoding.Binary.to_bytes_exn Script_chain_id.encoding chain_id\n in\n (Bytes (loc, bytes), ctxt)\n | Readable ->\n Gas.consume ctxt Unparse_costs.chain_id_readable >|? fun ctxt ->\n (String (loc, Script_chain_id.to_b58check chain_id), ctxt)\n\nlet unparse_bls12_381_g1 ~loc ctxt x =\n Gas.consume ctxt Unparse_costs.bls12_381_g1 >|? fun ctxt ->\n let bytes = Script_bls.G1.to_bytes x in\n (Bytes (loc, bytes), ctxt)\n\nlet unparse_bls12_381_g2 ~loc ctxt x =\n Gas.consume ctxt Unparse_costs.bls12_381_g2 >|? fun ctxt ->\n let bytes = Script_bls.G2.to_bytes x in\n (Bytes (loc, bytes), ctxt)\n\nlet unparse_bls12_381_fr ~loc ctxt x =\n Gas.consume ctxt Unparse_costs.bls12_381_fr >|? fun ctxt ->\n let bytes = Script_bls.Fr.to_bytes x in\n (Bytes (loc, bytes), ctxt)\n\nlet unparse_with_data_encoding ~loc ctxt s unparse_cost encoding =\n Lwt.return\n ( Gas.consume ctxt unparse_cost >|? fun ctxt ->\n let bytes = Data_encoding.Binary.to_bytes_exn encoding s in\n (Bytes (loc, bytes), ctxt) )\n\n(* -- Unparsing data of complex types -- *)\n\ntype ('ty, 'depth) comb_witness =\n | Comb_Pair : ('t, 'd) comb_witness -> (_ * 't, unit -> 'd) comb_witness\n | Comb_Any : (_, _) comb_witness\n\nlet unparse_pair (type r) ~loc unparse_l unparse_r ctxt mode\n (r_comb_witness : (r, unit -> unit -> _) comb_witness) (l, (r : r)) =\n unparse_l ctxt l >>=? fun (l, ctxt) ->\n unparse_r ctxt r >|=? fun (r, ctxt) ->\n (* Fold combs.\n For combs, three notations are supported:\n - a) [Pair x1 (Pair x2 ... (Pair xn-1 xn) ...)],\n - b) [Pair x1 x2 ... xn-1 xn], and\n - c) [{x1; x2; ...; xn-1; xn}].\n In readable mode, we always use b),\n in optimized mode we use the shortest to serialize:\n - for n=2, [Pair x1 x2],\n - for n=3, [Pair x1 (Pair x2 x3)],\n - for n>=4, [{x1; x2; ...; xn}].\n *)\n let res =\n match (mode, r_comb_witness, r) with\n | Optimized, Comb_Pair _, Micheline.Seq (_, r) ->\n (* Optimized case n > 4 *)\n Micheline.Seq (loc, l :: r)\n | ( Optimized,\n Comb_Pair (Comb_Pair _),\n Prim (_, D_Pair, [x2; Prim (_, D_Pair, [x3; x4], [])], []) ) ->\n (* Optimized case n = 4 *)\n Micheline.Seq (loc, [l; x2; x3; x4])\n | Readable, Comb_Pair _, Prim (_, D_Pair, xs, []) ->\n (* Readable case n > 2 *)\n Prim (loc, D_Pair, l :: xs, [])\n | _ ->\n (* The remaining cases are:\n - Optimized n = 2,\n - Optimized n = 3, and\n - Readable n = 2,\n - Optimized_legacy, any n *)\n Prim (loc, D_Pair, [l; r], [])\n in\n (res, ctxt)\n\nlet unparse_union ~loc unparse_l unparse_r ctxt = function\n | L l ->\n unparse_l ctxt l >|=? fun (l, ctxt) -> (Prim (loc, D_Left, [l], []), ctxt)\n | R r ->\n unparse_r ctxt r >|=? fun (r, ctxt) -> (Prim (loc, D_Right, [r], []), ctxt)\n\nlet unparse_option ~loc unparse_v ctxt = function\n | Some v ->\n unparse_v ctxt v >|=? fun (v, ctxt) -> (Prim (loc, D_Some, [v], []), ctxt)\n | None -> return (Prim (loc, D_None, [], []), ctxt)\n\n(* -- Unparsing data of comparable types -- *)\n\nlet comb_witness2 :\n type t tc. (t, tc) ty -> (t, unit -> unit -> unit) comb_witness = function\n | Pair_t (_, Pair_t _, _, _) -> Comb_Pair (Comb_Pair Comb_Any)\n | Pair_t _ -> Comb_Pair Comb_Any\n | _ -> Comb_Any\n\nlet rec unparse_comparable_data_rec :\n type a loc.\n loc:loc ->\n context ->\n unparsing_mode ->\n a comparable_ty ->\n a ->\n (loc Script.michelson_node * context) tzresult Lwt.t =\n fun ~loc ctxt mode ty a ->\n (* No need for stack_depth here. Unlike [unparse_data],\n [unparse_comparable_data] doesn't call [unparse_code].\n The stack depth is bounded by the type depth, currently bounded\n by 1000 (michelson_maximum_type_size). *)\n Gas.consume ctxt Unparse_costs.unparse_data_cycle\n (* We could have a smaller cost but let's keep it consistent with\n [unparse_data] for now. *)\n >>?=\n fun ctxt ->\n match (ty, a) with\n | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v\n | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v\n | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v\n | String_t, s -> Lwt.return @@ unparse_string ~loc ctxt s\n | Bytes_t, s -> Lwt.return @@ unparse_bytes ~loc ctxt s\n | Bool_t, b -> Lwt.return @@ unparse_bool ~loc ctxt b\n | Timestamp_t, t -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t\n | Address_t, address -> Lwt.return @@ unparse_address ~loc ctxt mode address\n | Tx_rollup_l2_address_t, address ->\n Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address\n | Signature_t, s -> Lwt.return @@ unparse_signature ~loc ctxt mode s\n | Mutez_t, v -> Lwt.return @@ unparse_mutez ~loc ctxt v\n | Key_t, k -> Lwt.return @@ unparse_key ~loc ctxt mode k\n | Key_hash_t, k -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k\n | Chain_id_t, chain_id ->\n Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id\n | Pair_t (tl, tr, _, YesYes), pair ->\n let r_witness = comb_witness2 tr in\n let unparse_l ctxt v = unparse_comparable_data_rec ~loc ctxt mode tl v in\n let unparse_r ctxt v = unparse_comparable_data_rec ~loc ctxt mode tr v in\n unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair\n | Union_t (tl, tr, _, YesYes), v ->\n let unparse_l ctxt v = unparse_comparable_data_rec ~loc ctxt mode tl v in\n let unparse_r ctxt v = unparse_comparable_data_rec ~loc ctxt mode tr v in\n unparse_union ~loc unparse_l unparse_r ctxt v\n | Option_t (t, _, Yes), v ->\n let unparse_v ctxt v = unparse_comparable_data_rec ~loc ctxt mode t v in\n unparse_option ~loc unparse_v ctxt v\n | Never_t, _ -> .\n\nlet account_for_future_serialization_cost unparsed_data ctxt =\n Gas.consume ctxt (Script.strip_locations_cost unparsed_data) >>? fun ctxt ->\n let unparsed_data = Micheline.strip_locations unparsed_data in\n Gas.consume ctxt (Script.micheline_serialization_cost unparsed_data)\n >|? fun ctxt -> (unparsed_data, ctxt)\n\ntype unparse_code_rec =\n t ->\n stack_depth:int ->\n unparsing_mode ->\n Script.node ->\n ((canonical_location, prim) node * t, error trace) result Lwt.t\n\nmodule type MICHELSON_PARSER = sig\n val opened_ticket_type :\n Script.location ->\n 'a comparable_ty ->\n (address, ('a, Script_int.n Script_int.num) pair) pair comparable_ty\n tzresult\n\n val parse_packable_ty :\n context ->\n stack_depth:int ->\n legacy:bool ->\n Script.node ->\n (ex_ty * context) tzresult\n\n val parse_data :\n unparse_code_rec:unparse_code_rec ->\n elab_conf:Script_ir_translator_config.elab_config ->\n stack_depth:int ->\n context ->\n allow_forged:bool ->\n ('a, 'ac) ty ->\n Script.node ->\n ('a * t) tzresult Lwt.t\nend\n\nmodule Data_unparser (P : MICHELSON_PARSER) = struct\n open Script_tc_errors\n\n (* -- Unparsing data of any type -- *)\n let rec unparse_data_rec :\n type a ac.\n context ->\n stack_depth:int ->\n unparsing_mode ->\n (a, ac) ty ->\n a ->\n (Script.node * context) tzresult Lwt.t =\n fun ctxt ~stack_depth mode ty a ->\n Gas.consume ctxt Unparse_costs.unparse_data_cycle >>?= fun ctxt ->\n let non_terminal_recursion ctxt mode ty a =\n if Compare.Int.(stack_depth > 10_000) then\n tzfail Script_tc_errors.Unparsing_too_many_recursive_calls\n else unparse_data_rec ctxt ~stack_depth:(stack_depth + 1) mode ty a\n in\n let loc = Micheline.dummy_location in\n match (ty, a) with\n | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v\n | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v\n | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v\n | String_t, s -> Lwt.return @@ unparse_string ~loc ctxt s\n | Bytes_t, s -> Lwt.return @@ unparse_bytes ~loc ctxt s\n | Bool_t, b -> Lwt.return @@ unparse_bool ~loc ctxt b\n | Timestamp_t, t -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t\n | Address_t, address -> Lwt.return @@ unparse_address ~loc ctxt mode address\n | Tx_rollup_l2_address_t, address ->\n Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address\n | Contract_t _, contract ->\n Lwt.return @@ unparse_contract ~loc ctxt mode contract\n | Signature_t, s -> Lwt.return @@ unparse_signature ~loc ctxt mode s\n | Mutez_t, v -> Lwt.return @@ unparse_mutez ~loc ctxt v\n | Key_t, k -> Lwt.return @@ unparse_key ~loc ctxt mode k\n | Key_hash_t, k -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k\n | Operation_t, operation ->\n Lwt.return @@ unparse_operation ~loc ctxt operation\n | Chain_id_t, chain_id ->\n Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id\n | Bls12_381_g1_t, x -> Lwt.return @@ unparse_bls12_381_g1 ~loc ctxt x\n | Bls12_381_g2_t, x -> Lwt.return @@ unparse_bls12_381_g2 ~loc ctxt x\n | Bls12_381_fr_t, x -> Lwt.return @@ unparse_bls12_381_fr ~loc ctxt x\n | Pair_t (tl, tr, _, _), pair ->\n let r_witness = comb_witness2 tr in\n let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in\n let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in\n unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair\n | Union_t (tl, tr, _, _), v ->\n let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in\n let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in\n unparse_union ~loc unparse_l unparse_r ctxt v\n | Option_t (t, _, _), v ->\n let unparse_v ctxt v = non_terminal_recursion ctxt mode t v in\n unparse_option ~loc unparse_v ctxt v\n | List_t (t, _), items ->\n List.fold_left_es\n (fun (l, ctxt) element ->\n non_terminal_recursion ctxt mode t element\n >|=? fun (unparsed, ctxt) -> (unparsed :: l, ctxt))\n ([], ctxt)\n items.elements\n >|=? fun (items, ctxt) -> (Micheline.Seq (loc, List.rev items), ctxt)\n | Ticket_t (t, _), {ticketer; contents; amount} ->\n (* ideally we would like to allow a little overhead here because it is only used for unparsing *)\n P.opened_ticket_type loc t >>?= fun t ->\n let destination : Destination.t = Contract ticketer in\n let addr = {destination; entrypoint = Entrypoint.default} in\n (unparse_data_rec [@tailcall])\n ctxt\n ~stack_depth\n mode\n t\n (addr, (contents, (amount :> Script_int.n Script_int.num)))\n | Set_t (t, _), set ->\n List.fold_left_es\n (fun (l, ctxt) item ->\n unparse_comparable_data_rec ~loc ctxt mode t item\n >|=? fun (item, ctxt) -> (item :: l, ctxt))\n ([], ctxt)\n (Script_set.fold (fun e acc -> e :: acc) set [])\n >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt)\n | Map_t (kt, vt, _), map ->\n let items = Script_map.fold (fun k v acc -> (k, v) :: acc) map [] in\n unparse_items_rec ctxt ~stack_depth:(stack_depth + 1) mode kt vt items\n >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt)\n | Big_map_t (_kt, _vt, _), Big_map {id = Some id; diff = {size; _}; _}\n when Compare.Int.( = ) size 0 ->\n return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt)\n | Big_map_t (kt, vt, _), Big_map {id = Some id; diff = {map; _}; _} ->\n let items =\n Big_map_overlay.fold (fun _ (k, v) acc -> (k, v) :: acc) map []\n in\n let items =\n (* Sort the items in Michelson comparison order and not in key\n hash order. This code path is only exercised for tracing,\n so we don't bother carbonating this sort operation\n precisely. Also, the sort uses a reverse compare because\n [unparse_items] will reverse the result. *)\n List.sort\n (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a)\n items\n in\n (* this can't fail if the original type is well-formed\n because [option vt] is always strictly smaller than [big_map kt vt] *)\n option_t loc vt >>?= fun vt ->\n unparse_items_rec ctxt ~stack_depth:(stack_depth + 1) mode kt vt items\n >|=? fun (items, ctxt) ->\n ( Micheline.Prim\n ( loc,\n D_Pair,\n [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)],\n [] ),\n ctxt )\n | Big_map_t (kt, vt, _), Big_map {id = None; diff = {map; _}; _} ->\n let items =\n Big_map_overlay.fold\n (fun _ (k, v) acc ->\n match v with None -> acc | Some v -> (k, v) :: acc)\n map\n []\n in\n let items =\n (* See note above. *)\n List.sort\n (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a)\n items\n in\n unparse_items_rec ctxt ~stack_depth:(stack_depth + 1) mode kt vt items\n >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt)\n | Lambda_t _, Lam (_, original_code) ->\n unparse_code_rec ctxt ~stack_depth:(stack_depth + 1) mode original_code\n | Lambda_t _, LamRec (_, original_code) ->\n unparse_code_rec ctxt ~stack_depth:(stack_depth + 1) mode original_code\n >|=? fun (body, ctxt) ->\n (Micheline.Prim (loc, D_Lambda_rec, [body], []), ctxt)\n | Never_t, _ -> .\n | Sapling_transaction_t _, s ->\n Lwt.return\n ( Gas.consume ctxt (Unparse_costs.sapling_transaction s)\n >|? fun ctxt ->\n let bytes =\n Data_encoding.Binary.to_bytes_exn Sapling.transaction_encoding s\n in\n (Bytes (loc, bytes), ctxt) )\n | Sapling_transaction_deprecated_t _, s ->\n Lwt.return\n ( Gas.consume ctxt (Unparse_costs.sapling_transaction_deprecated s)\n >|? fun ctxt ->\n let bytes =\n Data_encoding.Binary.to_bytes_exn\n Sapling.Legacy.transaction_encoding\n s\n in\n (Bytes (loc, bytes), ctxt) )\n | Sapling_state_t _, {id; diff; _} ->\n Lwt.return\n ( Gas.consume ctxt (Unparse_costs.sapling_diff diff) >|? fun ctxt ->\n ( (match diff with\n | {commitments_and_ciphertexts = []; nullifiers = []} -> (\n match id with\n | None -> Micheline.Seq (loc, [])\n | Some id ->\n let id = Sapling.Id.unparse_to_z id in\n Micheline.Int (loc, id))\n | diff -> (\n let diff_bytes =\n Data_encoding.Binary.to_bytes_exn Sapling.diff_encoding diff\n in\n let unparsed_diff = Bytes (loc, diff_bytes) in\n match id with\n | None -> unparsed_diff\n | Some id ->\n let id = Sapling.Id.unparse_to_z id in\n Micheline.Prim\n (loc, D_Pair, [Int (loc, id); unparsed_diff], []))),\n ctxt ) )\n | Chest_key_t, s ->\n unparse_with_data_encoding\n ~loc\n ctxt\n s\n Unparse_costs.chest_key\n Script_timelock.chest_key_encoding\n | Chest_t, s ->\n unparse_with_data_encoding\n ~loc\n ctxt\n s\n (Unparse_costs.chest\n ~plaintext_size:(Script_timelock.get_plaintext_size s))\n Script_timelock.chest_encoding\n\n and unparse_items_rec :\n type k v vc.\n context ->\n stack_depth:int ->\n unparsing_mode ->\n k comparable_ty ->\n (v, vc) ty ->\n (k * v) list ->\n (Script.node list * context) tzresult Lwt.t =\n fun ctxt ~stack_depth mode kt vt items ->\n List.fold_left_es\n (fun (l, ctxt) (k, v) ->\n let loc = Micheline.dummy_location in\n unparse_comparable_data_rec ~loc ctxt mode kt k >>=? fun (key, ctxt) ->\n unparse_data_rec ctxt ~stack_depth:(stack_depth + 1) mode vt v\n >|=? fun (value, ctxt) ->\n (Prim (loc, D_Elt, [key; value], []) :: l, ctxt))\n ([], ctxt)\n items\n\n and unparse_code_rec ctxt ~stack_depth mode code =\n let elab_conf = Script_ir_translator_config.make ~legacy:true () in\n Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>?= fun ctxt ->\n let non_terminal_recursion ctxt mode code =\n if Compare.Int.(stack_depth > 10_000) then\n tzfail Unparsing_too_many_recursive_calls\n else unparse_code_rec ctxt ~stack_depth:(stack_depth + 1) mode code\n in\n match code with\n | Prim (loc, I_PUSH, [ty; data], annot) ->\n P.parse_packable_ty\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy:elab_conf.legacy\n ty\n >>?= fun (Ex_ty t, ctxt) ->\n let allow_forged =\n false\n (* Forgeable in PUSH data are already forbidden at parsing,\n the only case for which this matters is storing a lambda resulting\n from APPLYing a non-forgeable but this cannot happen either as long\n as all packable values are also forgeable. *)\n in\n P.parse_data\n ~unparse_code_rec\n ~elab_conf\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~allow_forged\n t\n data\n >>=? fun (data, ctxt) ->\n unparse_data_rec ctxt ~stack_depth:(stack_depth + 1) mode t data\n >>=? fun (data, ctxt) ->\n return (Prim (loc, I_PUSH, [ty; data], annot), ctxt)\n | Seq (loc, items) ->\n List.fold_left_es\n (fun (l, ctxt) item ->\n non_terminal_recursion ctxt mode item >|=? fun (item, ctxt) ->\n (item :: l, ctxt))\n ([], ctxt)\n items\n >>=? fun (items, ctxt) ->\n return (Micheline.Seq (loc, List.rev items), ctxt)\n | Prim (loc, prim, items, annot) ->\n List.fold_left_es\n (fun (l, ctxt) item ->\n non_terminal_recursion ctxt mode item >|=? fun (item, ctxt) ->\n (item :: l, ctxt))\n ([], ctxt)\n items\n >>=? fun (items, ctxt) ->\n return (Prim (loc, prim, List.rev items, annot), ctxt)\n | (Int _ | String _ | Bytes _) as atom -> return (atom, ctxt)\n\n let unparse_data ctxt ~stack_depth mode ty v =\n unparse_data_rec ctxt ~stack_depth mode ty v\n >>=? fun (unparsed_data, ctxt) ->\n Lwt.return (account_for_future_serialization_cost unparsed_data ctxt)\n\n let unparse_code ctxt ~stack_depth mode v =\n unparse_code_rec ctxt ~stack_depth mode v >>=? fun (unparsed_data, ctxt) ->\n Lwt.return (account_for_future_serialization_cost unparsed_data ctxt)\n\n let unparse_items ctxt ~stack_depth mode ty vty vs =\n unparse_items_rec ctxt ~stack_depth mode ty vty vs\n >>=? fun (unparsed_datas, ctxt) ->\n List.fold_left_e\n (fun (acc, ctxt) unparsed_data ->\n account_for_future_serialization_cost unparsed_data ctxt\n >|? fun (unparsed_data, ctxt) -> (unparsed_data :: acc, ctxt))\n ([], ctxt)\n unparsed_datas\n >>?= fun (unparsed_datas, ctxt) -> return (List.rev unparsed_datas, ctxt)\n\n module Internal_for_benchmarking = struct\n let unparse_data = unparse_data_rec\n\n let unparse_code = unparse_code_rec\n end\nend\n\nlet unparse_comparable_data ctxt mode ty v =\n unparse_comparable_data_rec ctxt ~loc:() mode ty v\n >>=? fun (unparsed_data, ctxt) ->\n Lwt.return (account_for_future_serialization_cost unparsed_data ctxt)\n" ;
} ;
{ name = "Script_ir_translator" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(* Overview:\n\n This mli is organized into roughly three parts:\n\n 1. A set of new types prefixed with \"ex_\"\n Michelson is encoded in a GADT that preserves certain properties about its\n type system. If you haven't read about GADT's, check out the relevant section\n in the Tezos docs:\n https://tezos.gitlab.io/developer/gadt.html#generalized-algebraic-data-types-gadts\n\n The idea is that type representing a Michelson type, ['a ty], is parameterized\n by a type 'a. But that 'a can't be just _any_ type; it must be valid according\n to the definition of ['a ty]. Thus, if I give you a value of type ['a ty],\n all you know is that \"there exists some 'a such that 'a ty exists\". You must be\n careful not to accidentally quantify 'a universally, that is \"for all 'a,\n 'a ty exists\", otherwise you'll get an annoying error about 'a trying to escape\n it's scope. We do this by hiding 'a in an existential type. This is what\n ex_comparable_ty, ex_ty, ex_stack_ty, etc. do.\n\n 2. A set of functions dealing with high-level Michelson types:\n This module also provides functions for interacting with the list, map,\n set, and big_map Michelson types.\n\n 3. A set of functions for parsing and typechecking Michelson.\n Finally, and what you likely came for, the module provides many functions prefixed\n with \"parse_\" that convert untyped Micheline (which is essentially S-expressions\n with a few primitive atom types) into the GADT encoding well-typed Michelson. Likewise\n there is a number of functions prefixed \"unparse_\" that do the reverse. These functions\n consume gas, and thus are parameterized by an [Alpha_context.t].\n\n The variety of functions reflects the variety of things one might want to parse,\n from [parse_data] for arbitrary Micheline expressions to [parse_contract_data] for\n well-formed Michelson contracts.\n*)\n\n(** {1 Michelson Existential Witness types} *)\nopen Alpha_context\n\nopen Script_typed_ir\nopen Script_tc_errors\n\ntype ('ta, 'tb) eq = Eq : ('same, 'same) eq\n\ntype ex_comparable_ty =\n | Ex_comparable_ty : 'a Script_typed_ir.comparable_ty -> ex_comparable_ty\n\ntype ex_parameter_ty_and_entrypoints =\n | Ex_parameter_ty_and_entrypoints : {\n arg_type : ('a, _) Script_typed_ir.ty;\n entrypoints : 'a Script_typed_ir.entrypoints;\n }\n -> ex_parameter_ty_and_entrypoints\n\ntype ex_stack_ty =\n | Ex_stack_ty : ('a, 's) Script_typed_ir.stack_ty -> ex_stack_ty\n\ntype ex_script = Ex_script : ('a, 'b) Script_typed_ir.script -> ex_script\n\ntype toplevel = {\n code_field : Script.node;\n arg_type : Script.node;\n storage_type : Script.node;\n views : Script_typed_ir.view_map;\n}\n\ntype ('arg, 'storage) code =\n | Code : {\n code :\n ( ('arg, 'storage) Script_typed_ir.pair,\n ( Script_typed_ir.operation Script_list.t,\n 'storage )\n Script_typed_ir.pair )\n Script_typed_ir.lambda;\n arg_type : ('arg, _) Script_typed_ir.ty;\n storage_type : ('storage, _) Script_typed_ir.ty;\n views : Script_typed_ir.view_map;\n entrypoints : 'arg Script_typed_ir.entrypoints;\n code_size : Cache_memory_helpers.sint;\n (** This is an over-approximation of the value size in memory, in\n bytes, of the contract's static part, that is its source\n code. This includes the code of the contract as well as the code\n of the views. The storage size is not taken into account by this\n field as it has a dynamic size. *)\n }\n -> ('arg, 'storage) code\n\ntype ex_code = Ex_code : ('a, 'c) code -> ex_code\n\ntype 'storage typed_view =\n | Typed_view : {\n input_ty : ('input, _) Script_typed_ir.ty;\n output_ty : ('output, _) Script_typed_ir.ty;\n kinstr :\n ( 'input * 'storage,\n Script_typed_ir.end_of_stack,\n 'output,\n Script_typed_ir.end_of_stack )\n Script_typed_ir.kinstr;\n original_code_expr : Script.node;\n }\n -> 'storage typed_view\n\ntype 'storage typed_view_map =\n (Script_string.t, 'storage typed_view) Script_typed_ir.map\n\ntype ('a, 's, 'b, 'u) cinstr = {\n apply :\n 'r 'f.\n ('b, 'u, 'r, 'f) Script_typed_ir.kinstr ->\n ('a, 's, 'r, 'f) Script_typed_ir.kinstr;\n}\n[@@ocaml.unboxed]\n\ntype ('a, 's, 'b, 'u) descr = {\n loc : Script.location;\n bef : ('a, 's) Script_typed_ir.stack_ty;\n aft : ('b, 'u) Script_typed_ir.stack_ty;\n instr : ('a, 's, 'b, 'u) cinstr;\n}\n\ntype tc_context = Script_tc_context.t\n\ntype ('a, 's) judgement =\n | Typed : ('a, 's, 'b, 'u) descr -> ('a, 's) judgement\n | Failed : {\n descr : 'b 'u. ('b, 'u) Script_typed_ir.stack_ty -> ('a, 's, 'b, 'u) descr;\n }\n -> ('a, 's) judgement\n\nval close_descr :\n ('a, 'b, 'c, 'd) descr -> ('a, 'b, 'c, 'd) Script_typed_ir.kdescr\n\n(* ---- Lists, Sets and Maps ----------------------------------------------- *)\n\n(** {2 High-level Michelson Data Types} *)\nval ty_eq :\n error_details:(Script.location, 'error_trace) error_details ->\n ('a, 'ac) Script_typed_ir.ty ->\n ('b, 'bc) Script_typed_ir.ty ->\n ( (('a, 'ac) Script_typed_ir.ty, ('b, 'bc) Script_typed_ir.ty) eq,\n 'error_trace )\n Gas_monad.t\n\n(** {3 Parsing and Typechecking Michelson} *)\nval parse_comparable_data :\n ?type_logger:Script_ir_translator_config.type_logger ->\n context ->\n 'a Script_typed_ir.comparable_ty ->\n Script.node ->\n ('a * context) tzresult Lwt.t\n\n(* Parsing a Micheline node data into an IR-typed data. *)\nval parse_data :\n elab_conf:Script_ir_translator_config.elab_config ->\n context ->\n allow_forged:bool ->\n ('a, _) Script_typed_ir.ty ->\n Script.node ->\n ('a * context) tzresult Lwt.t\n\n(* Unparsing an IR-typed data back into a Micheline node data *)\nval unparse_data :\n context ->\n Script_ir_unparser.unparsing_mode ->\n ('a, _) Script_typed_ir.ty ->\n 'a ->\n (Script.expr * context) tzresult Lwt.t\n\nval unparse_code :\n context ->\n Script_ir_unparser.unparsing_mode ->\n Script.node ->\n (Script.expr * context) tzresult Lwt.t\n\n(** For benchmarking purpose, we also export versions of the unparsing\n functions which don't call location stripping. These functions are\n not carbonated and should not be called directly from the protocol. *)\nmodule Internal_for_benchmarking : sig\n val unparse_data :\n context ->\n stack_depth:int ->\n Script_ir_unparser.unparsing_mode ->\n ('a, 'ac) ty ->\n 'a ->\n (Script.node * context) tzresult Lwt.t\n\n val unparse_code :\n context ->\n stack_depth:int ->\n Script_ir_unparser.unparsing_mode ->\n Script.node ->\n (Script.node * context) tzresult Lwt.t\nend\n\nval parse_instr :\n elab_conf:Script_ir_translator_config.elab_config ->\n tc_context ->\n context ->\n Script.node ->\n ('a, 's) Script_typed_ir.stack_ty ->\n (('a, 's) judgement * context) tzresult Lwt.t\n\n(**\n [parse_ty] specialized for the right-hand side part of a big map type, i.e.\n the `value` in `big_map key value`.\n*)\nval parse_big_map_value_ty :\n context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult\n\nval parse_packable_ty :\n context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult\n\nval parse_passable_ty :\n context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult\n\nval parse_comparable_ty :\n context -> Script.node -> (ex_comparable_ty * context) tzresult\n\nval parse_parameter_ty_and_entrypoints :\n context ->\n legacy:bool ->\n Script.node ->\n (ex_parameter_ty_and_entrypoints * context) tzresult\n\nval parse_view_input_ty :\n context ->\n stack_depth:int ->\n legacy:bool ->\n Script.node ->\n (ex_ty * context) tzresult\n\nval parse_view_output_ty :\n context ->\n stack_depth:int ->\n legacy:bool ->\n Script.node ->\n (ex_ty * context) tzresult\n\nval parse_view :\n elab_conf:Script_ir_translator_config.elab_config ->\n context ->\n ('storage, _) Script_typed_ir.ty ->\n Script_typed_ir.view ->\n ('storage typed_view * context) tzresult Lwt.t\n\nval parse_views :\n elab_conf:Script_ir_translator_config.elab_config ->\n context ->\n ('storage, _) Script_typed_ir.ty ->\n Script_typed_ir.view_map ->\n ('storage typed_view_map * context) tzresult Lwt.t\n\n(**\n [parse_ty] allowing big_map values, operations, contract and tickets.\n*)\nval parse_any_ty :\n context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult\n\n(** We expose [parse_ty] for convenience to external tools. Please use\n specialized versions such as [parse_packable_ty], [parse_passable_ty],\n [parse_comparable_ty], or [parse_big_map_value_ty] if possible. *)\nval parse_ty :\n context ->\n legacy:bool ->\n allow_lazy_storage:bool ->\n allow_operation:bool ->\n allow_contract:bool ->\n allow_ticket:bool ->\n Script.node ->\n (ex_ty * context) tzresult\n\nval parse_toplevel :\n context -> legacy:bool -> Script.expr -> (toplevel * context) tzresult Lwt.t\n\n(** High-level function to typecheck a Michelson script. This function is not\n used for validating operations but only for the [typecheck_code] RPC.\n\n If [show_types] is set to [true], details of the typechecking are returned\n in the [type_map], otherwise the returned [type_map] is empty. *)\nval typecheck_code :\n legacy:bool ->\n show_types:bool ->\n context ->\n Script.expr ->\n (type_map * context) tzresult Lwt.t\n\nval parse_code :\n elab_conf:Script_ir_translator_config.elab_config ->\n context ->\n code:Script.lazy_expr ->\n (ex_code * context) tzresult Lwt.t\n\nval parse_storage :\n elab_conf:Script_ir_translator_config.elab_config ->\n context ->\n allow_forged:bool ->\n ('storage, _) Script_typed_ir.ty ->\n storage:Script.lazy_expr ->\n ('storage * context) tzresult Lwt.t\n\n(** Combines [parse_code] and [parse_storage] *)\nval parse_script :\n elab_conf:Script_ir_translator_config.elab_config ->\n context ->\n allow_forged_in_storage:bool ->\n Script.t ->\n (ex_script * context) tzresult Lwt.t\n\n(* Gas accounting may not be perfect in this function, as it is only called by RPCs. *)\nval parse_and_unparse_script_unaccounted :\n context ->\n legacy:bool ->\n allow_forged_in_storage:bool ->\n Script_ir_unparser.unparsing_mode ->\n normalize_types:bool ->\n Script.t ->\n (Script.t * context) tzresult Lwt.t\n\nval parse_contract_data :\n context ->\n Script.location ->\n ('a, _) Script_typed_ir.ty ->\n Destination.t ->\n entrypoint:Entrypoint.t ->\n (context * 'a Script_typed_ir.typed_contract) tzresult Lwt.t\n\nval parse_contract_for_script :\n context ->\n Script.location ->\n ('a, _) Script_typed_ir.ty ->\n Destination.t ->\n entrypoint:Entrypoint.t ->\n (context * 'a Script_typed_ir.typed_contract option) tzresult Lwt.t\n\n(** ['a ex_ty_cstr] is like [ex_ty], but also adds to the existential a function\n used to reconstruct a value of type ['a] from the internal type of the\n existential. Typically, it will be used to go from the type of an\n entry-point to the full type of a contract. *)\ntype 'a ex_ty_cstr =\n | Ex_ty_cstr : {\n ty : ('b, _) Script_typed_ir.ty;\n construct : 'b -> 'a;\n original_type_expr : Script.node;\n }\n -> 'a ex_ty_cstr\n\nval find_entrypoint :\n error_details:(_, 'error_trace) error_details ->\n ('t, _) Script_typed_ir.ty ->\n 't Script_typed_ir.entrypoints ->\n Entrypoint.t ->\n ('t ex_ty_cstr, 'error_trace) Gas_monad.t\n\nval list_entrypoints_uncarbonated :\n ('t, _) Script_typed_ir.ty ->\n 't Script_typed_ir.entrypoints ->\n Michelson_v1_primitives.prim list list\n * (ex_ty * Script.node) Entrypoint.Map.t\n\nval pack_data :\n context ->\n ('a, _) Script_typed_ir.ty ->\n 'a ->\n (bytes * context) tzresult Lwt.t\n\nval hash_comparable_data :\n context ->\n 'a Script_typed_ir.comparable_ty ->\n 'a ->\n (Script_expr_hash.t * context) tzresult Lwt.t\n\nval hash_data :\n context ->\n ('a, _) Script_typed_ir.ty ->\n 'a ->\n (Script_expr_hash.t * context) tzresult Lwt.t\n\ntype lazy_storage_ids\n\nval no_lazy_storage_id : lazy_storage_ids\n\n(** Traverse the given type, producing a {!lazy_storage_ids} for\n use with {!extract_lazy_storage_diff}.\n *)\nval collect_lazy_storage :\n context ->\n ('a, _) Script_typed_ir.ty ->\n 'a ->\n (lazy_storage_ids * context) tzresult\n\nval list_of_big_map_ids : lazy_storage_ids -> Big_map.Id.t list\n\n(** Produce a lazy storage diff, containing in-memory writes to\n lazy data structures such as big_maps yet to be committed.\n\n The resulting diff can be committed to the underlying storage\n (context) using [Lazy_storage_diff.apply].\n\n @param to_duplicate\n Lazy data structure reference produced via {!collect_lazy_storage}\n that can not be reused. Typically collected via traversing\n the parameters to a smart contract.\n @param to_update\n Lazy data structure reference produced via {!collect_lazy_storage}\n that can be reused. Typically collected via traversing the previous\n storage of a smart contract.\n *)\nval extract_lazy_storage_diff :\n context ->\n Script_ir_unparser.unparsing_mode ->\n temporary:bool ->\n to_duplicate:lazy_storage_ids ->\n to_update:lazy_storage_ids ->\n ('a, _) Script_typed_ir.ty ->\n 'a ->\n ('a * Lazy_storage.diffs option * context) tzresult Lwt.t\n\n(* return [None] if none or more than one found *)\nval get_single_sapling_state :\n context ->\n ('a, _) Script_typed_ir.ty ->\n 'a ->\n (Sapling.Id.t option * context) tzresult\n\n(** [code_size ctxt code views] returns an overapproximation of the size of\n the in-memory representation of [code] and [views] in bytes in the\n context [ctxt]. *)\nval code_size :\n context ->\n ('a, 'b) Script_typed_ir.lambda ->\n Script_typed_ir.view_map ->\n (Cache_memory_helpers.sint * context) tzresult\n\n(** [script_size script] returns an overapproximation of the size of\n the in-memory representation of [script] in bytes as well as the cost\n associated to computing that overapproximation. *)\nval script_size : ex_script -> int * Gas_limit_repr.cost\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech <contact@trili.tech> *)\n(* Copyright (c) 2022 DaiLambda, Inc. <contact@dailambda,jp> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\nopen Micheline\nopen Script\nopen Script_tc_errors\nopen Script_ir_annot\nopen Script_typed_ir\nopen Script_ir_unparser\nmodule Typecheck_costs = Michelson_v1_gas.Cost_of.Typechecking\nmodule Unparse_costs = Michelson_v1_gas.Cost_of.Unparsing\nmodule Tc_context = Script_tc_context\n\ntype elab_conf = Script_ir_translator_config.elab_config\n\ntype ex_stack_ty = Ex_stack_ty : ('a, 's) stack_ty -> ex_stack_ty\n\n(* Equality witnesses *)\ntype ('ta, 'tb) eq = Eq : ('same, 'same) eq\n\n(*\n\n The following type represents an instruction parameterized by its\n continuation. During the elaboration of the typed term, a sequence\n of instructions in Micheline is read from left to right: hence, the\n elaboration needs to wait for the next instruction to be elaborated\n to be able to construct the current instruction.\n\n*)\ntype ('a, 's, 'b, 'u) cinstr = {\n apply : 'r 'f. ('b, 'u, 'r, 'f) kinstr -> ('a, 's, 'r, 'f) kinstr;\n}\n[@@ocaml.unboxed]\n\n(*\n\n While a [Script_typed_ir.descr] contains a fully defined\n instruction, [descr] contains a [cinstr], that is an instruction\n parameterized by the next instruction, as explained in the previous\n comment.\n\n*)\ntype ('a, 's, 'b, 'u) descr = {\n loc : Script.location;\n bef : ('a, 's) stack_ty;\n aft : ('b, 'u) stack_ty;\n instr : ('a, 's, 'b, 'u) cinstr;\n}\n\nlet close_descr {loc; bef; aft; instr} =\n let kinstr = instr.apply (IHalt loc) in\n {kloc = loc; kbef = bef; kaft = aft; kinstr}\n\nlet compose_descr :\n type a s b u c v.\n Script.location ->\n (a, s, b, u) descr ->\n (b, u, c, v) descr ->\n (a, s, c, v) descr =\n fun loc d1 d2 ->\n {\n loc;\n bef = d1.bef;\n aft = d2.aft;\n instr = {apply = (fun k -> d1.instr.apply (d2.instr.apply k))};\n }\n\ntype tc_context = Tc_context.t\n\n(* ---- Error helpers -------------------------------------------------------*)\n\nlet location = function\n | Prim (loc, _, _, _)\n | Int (loc, _)\n | String (loc, _)\n | Bytes (loc, _)\n | Seq (loc, _) ->\n loc\n\nlet kind_equal a b =\n match (a, b) with\n | Int_kind, Int_kind\n | String_kind, String_kind\n | Bytes_kind, Bytes_kind\n | Prim_kind, Prim_kind\n | Seq_kind, Seq_kind ->\n true\n | _ -> false\n\nlet kind = function\n | Int _ -> Int_kind\n | String _ -> String_kind\n | Bytes _ -> Bytes_kind\n | Prim _ -> Prim_kind\n | Seq _ -> Seq_kind\n\nlet unexpected expr exp_kinds exp_ns exp_prims =\n match expr with\n | Int (loc, _) -> Invalid_kind (loc, Prim_kind :: exp_kinds, Int_kind)\n | String (loc, _) -> Invalid_kind (loc, Prim_kind :: exp_kinds, String_kind)\n | Bytes (loc, _) -> Invalid_kind (loc, Prim_kind :: exp_kinds, Bytes_kind)\n | Seq (loc, _) -> Invalid_kind (loc, Prim_kind :: exp_kinds, Seq_kind)\n | Prim (loc, name, _, _) -> (\n let open Michelson_v1_primitives in\n match (namespace name, exp_ns) with\n | Type_namespace, Type_namespace\n | Instr_namespace, Instr_namespace\n | Constant_namespace, Constant_namespace ->\n Invalid_primitive (loc, exp_prims, name)\n | ns, _ -> Invalid_namespace (loc, name, exp_ns, ns))\n\nlet check_kind kinds expr =\n let kind = kind expr in\n if List.exists (kind_equal kind) kinds then Result.return_unit\n else\n let loc = location expr in\n error (Invalid_kind (loc, kinds, kind))\n\nlet check_comparable :\n type a ac.\n Script.location -> (a, ac) ty -> (ac, Dependent_bool.yes) eq tzresult =\n fun loc ty ->\n match is_comparable ty with\n | Yes -> ok Eq\n | No ->\n let t = Script_ir_unparser.serialize_ty_for_error ty in\n error (Comparable_type_expected (loc, t))\n\nlet pack_node unparsed ctxt =\n let bytes =\n Data_encoding.(\n Binary.to_bytes_exn (tup2 (Fixed.string Plain 1) expr_encoding))\n (\"\\x05\", unparsed)\n in\n (bytes, ctxt)\n\nlet pack_comparable_data ctxt ty data =\n unparse_comparable_data ctxt Optimized_legacy ty data\n >|=? fun (unparsed, ctxt) -> pack_node unparsed ctxt\n\nlet hash_bytes ctxt bytes =\n Gas.consume ctxt (Michelson_v1_gas.Cost_of.Interpreter.blake2b bytes)\n >|? fun ctxt -> (Script_expr_hash.(hash_bytes [bytes]), ctxt)\n\nlet hash_comparable_data ctxt ty data =\n pack_comparable_data ctxt ty data >>=? fun (bytes, ctxt) ->\n Lwt.return @@ hash_bytes ctxt bytes\n\n(* ---- Tickets ------------------------------------------------------------ *)\n\n(*\n All comparable types are dupable, this function exists only to not forget\n checking this property when adding new types.\n*)\nlet check_dupable_comparable_ty : type a. a comparable_ty -> unit = function\n | Unit_t | Never_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t\n | Mutez_t | Bool_t | Key_hash_t | Key_t | Timestamp_t | Chain_id_t | Address_t\n | Tx_rollup_l2_address_t | Pair_t _ | Union_t _ | Option_t _ ->\n ()\n\nlet check_dupable_ty ctxt loc ty =\n let rec aux : type a ac. location -> (a, ac) ty -> (unit, error) Gas_monad.t =\n fun loc ty ->\n let open Gas_monad.Syntax in\n let* () = Gas_monad.consume_gas Typecheck_costs.check_dupable_cycle in\n match ty with\n | Unit_t -> return_unit\n | Int_t -> return_unit\n | Nat_t -> return_unit\n | Signature_t -> return_unit\n | String_t -> return_unit\n | Bytes_t -> return_unit\n | Mutez_t -> return_unit\n | Key_hash_t -> return_unit\n | Key_t -> return_unit\n | Timestamp_t -> return_unit\n | Address_t -> return_unit\n | Tx_rollup_l2_address_t -> return_unit\n | Bool_t -> return_unit\n | Contract_t _ -> return_unit\n | Operation_t -> return_unit\n | Chain_id_t -> return_unit\n | Never_t -> return_unit\n | Bls12_381_g1_t -> return_unit\n | Bls12_381_g2_t -> return_unit\n | Bls12_381_fr_t -> return_unit\n | Sapling_state_t _ -> return_unit\n | Sapling_transaction_t _ -> return_unit\n | Sapling_transaction_deprecated_t _ -> return_unit\n | Chest_t -> return_unit\n | Chest_key_t -> return_unit\n | Ticket_t _ -> fail @@ Unexpected_ticket loc\n | Pair_t (ty_a, ty_b, _, _) ->\n let* () = aux loc ty_a in\n aux loc ty_b\n | Union_t (ty_a, ty_b, _, _) ->\n let* () = aux loc ty_a in\n aux loc ty_b\n | Lambda_t (_, _, _) ->\n (*\n Lambda are dupable as long as:\n - they don't contain non-dupable values, e.g. in `PUSH`\n (mostly non-dupable values should probably be considered forged)\n - they are not the result of a partial application on a non-dupable\n value. `APPLY` rejects non-packable types (because of `PUSH`).\n Hence non-dupable should imply non-packable.\n *)\n return_unit\n | Option_t (ty, _, _) -> aux loc ty\n | List_t (ty, _) -> aux loc ty\n | Set_t (key_ty, _) ->\n let () = check_dupable_comparable_ty key_ty in\n return_unit\n | Map_t (key_ty, val_ty, _) ->\n let () = check_dupable_comparable_ty key_ty in\n aux loc val_ty\n | Big_map_t (key_ty, val_ty, _) ->\n let () = check_dupable_comparable_ty key_ty in\n aux loc val_ty\n in\n let gas = aux loc ty in\n Gas_monad.run ctxt gas >>? fun (res, ctxt) ->\n match res with Ok () -> ok ctxt | Error e -> error e\n\nlet type_metadata_eq :\n type error_trace.\n error_details:(_, error_trace) error_details ->\n 'a ty_metadata ->\n 'b ty_metadata ->\n (unit, error_trace) result =\n fun ~error_details {size = size_a} {size = size_b} ->\n Type_size.check_eq ~error_details size_a size_b\n\nlet default_ty_eq_error loc ty1 ty2 =\n let ty1 = serialize_ty_for_error ty1 in\n let ty2 = serialize_ty_for_error ty2 in\n Inconsistent_types (loc, ty1, ty2)\n\nlet memo_size_eq :\n type error_trace.\n error_details:(_, error_trace) error_details ->\n Sapling.Memo_size.t ->\n Sapling.Memo_size.t ->\n (unit, error_trace) result =\n fun ~error_details ms1 ms2 ->\n if Sapling.Memo_size.equal ms1 ms2 then Result.return_unit\n else\n Error\n (match error_details with\n | Fast -> Inconsistent_types_fast\n | Informative _ -> trace_of_error @@ Inconsistent_memo_sizes (ms1, ms2))\n\n(* Check that two types are equal.\n\n The result is an equality witness between the types of the two inputs within\n the gas monad (for gas consumption).\n*)\nlet rec ty_eq :\n type a ac b bc error_trace.\n error_details:(Script.location, error_trace) error_details ->\n (a, ac) ty ->\n (b, bc) ty ->\n (((a, ac) ty, (b, bc) ty) eq, error_trace) Gas_monad.t =\n fun ~error_details ty1 ty2 ->\n let type_metadata_eq meta1 meta2 =\n Gas_monad.of_result (type_metadata_eq ~error_details meta1 meta2)\n |> Gas_monad.record_trace_eval ~error_details (fun loc ->\n default_ty_eq_error loc ty1 ty2)\n in\n let memo_size_eq ms1 ms2 =\n Gas_monad.of_result (memo_size_eq ~error_details ms1 ms2)\n in\n let rec help :\n type ta tac tb tbc.\n (ta, tac) ty ->\n (tb, tbc) ty ->\n (((ta, tac) ty, (tb, tbc) ty) eq, error_trace) Gas_monad.t =\n fun ty1 ty2 ->\n help0 ty1 ty2\n |> Gas_monad.record_trace_eval ~error_details (fun loc ->\n default_ty_eq_error loc ty1 ty2)\n and help0 :\n type ta tac tb tbc.\n (ta, tac) ty ->\n (tb, tbc) ty ->\n (((ta, tac) ty, (tb, tbc) ty) eq, error_trace) Gas_monad.t =\n fun ty1 ty2 ->\n let open Gas_monad.Syntax in\n let* () = Gas_monad.consume_gas Typecheck_costs.merge_cycle in\n let not_equal () =\n Gas_monad.of_result\n @@ Error\n (match error_details with\n | Fast -> (Inconsistent_types_fast : error_trace)\n | Informative loc ->\n trace_of_error @@ default_ty_eq_error loc ty1 ty2)\n in\n match (ty1, ty2) with\n | Unit_t, Unit_t -> return (Eq : ((ta, tac) ty, (tb, tbc) ty) eq)\n | Unit_t, _ -> not_equal ()\n | Int_t, Int_t -> return Eq\n | Int_t, _ -> not_equal ()\n | Nat_t, Nat_t -> return Eq\n | Nat_t, _ -> not_equal ()\n | Key_t, Key_t -> return Eq\n | Key_t, _ -> not_equal ()\n | Key_hash_t, Key_hash_t -> return Eq\n | Key_hash_t, _ -> not_equal ()\n | String_t, String_t -> return Eq\n | String_t, _ -> not_equal ()\n | Bytes_t, Bytes_t -> return Eq\n | Bytes_t, _ -> not_equal ()\n | Signature_t, Signature_t -> return Eq\n | Signature_t, _ -> not_equal ()\n | Mutez_t, Mutez_t -> return Eq\n | Mutez_t, _ -> not_equal ()\n | Timestamp_t, Timestamp_t -> return Eq\n | Timestamp_t, _ -> not_equal ()\n | Address_t, Address_t -> return Eq\n | Address_t, _ -> not_equal ()\n | Tx_rollup_l2_address_t, Tx_rollup_l2_address_t -> return Eq\n | Tx_rollup_l2_address_t, _ -> not_equal ()\n | Bool_t, Bool_t -> return Eq\n | Bool_t, _ -> not_equal ()\n | Chain_id_t, Chain_id_t -> return Eq\n | Chain_id_t, _ -> not_equal ()\n | Never_t, Never_t -> return Eq\n | Never_t, _ -> not_equal ()\n | Operation_t, Operation_t -> return Eq\n | Operation_t, _ -> not_equal ()\n | Bls12_381_g1_t, Bls12_381_g1_t -> return Eq\n | Bls12_381_g1_t, _ -> not_equal ()\n | Bls12_381_g2_t, Bls12_381_g2_t -> return Eq\n | Bls12_381_g2_t, _ -> not_equal ()\n | Bls12_381_fr_t, Bls12_381_fr_t -> return Eq\n | Bls12_381_fr_t, _ -> not_equal ()\n | Map_t (tal, tar, meta1), Map_t (tbl, tbr, meta2) ->\n let* () = type_metadata_eq meta1 meta2 in\n let* Eq = help tar tbr in\n let+ Eq = ty_eq ~error_details tal tbl in\n (Eq : ((ta, tac) ty, (tb, tbc) ty) eq)\n | Map_t _, _ -> not_equal ()\n | Big_map_t (tal, tar, meta1), Big_map_t (tbl, tbr, meta2) ->\n let* () = type_metadata_eq meta1 meta2 in\n let* Eq = help tar tbr in\n let+ Eq = ty_eq ~error_details tal tbl in\n (Eq : ((ta, tac) ty, (tb, tbc) ty) eq)\n | Big_map_t _, _ -> not_equal ()\n | Set_t (ea, meta1), Set_t (eb, meta2) ->\n let* () = type_metadata_eq meta1 meta2 in\n let+ Eq = ty_eq ~error_details ea eb in\n (Eq : ((ta, tac) ty, (tb, tbc) ty) eq)\n | Set_t _, _ -> not_equal ()\n | Ticket_t (ea, meta1), Ticket_t (eb, meta2) ->\n let* () = type_metadata_eq meta1 meta2 in\n let+ Eq = ty_eq ~error_details ea eb in\n (Eq : ((ta, tac) ty, (tb, tbc) ty) eq)\n | Ticket_t _, _ -> not_equal ()\n | Pair_t (tal, tar, meta1, cmp1), Pair_t (tbl, tbr, meta2, cmp2) ->\n let* () = type_metadata_eq meta1 meta2 in\n let* Eq = help tal tbl in\n let+ Eq = help tar tbr in\n let Eq = Dependent_bool.merge_dand cmp1 cmp2 in\n (Eq : ((ta, tac) ty, (tb, tbc) ty) eq)\n | Pair_t _, _ -> not_equal ()\n | Union_t (tal, tar, meta1, cmp1), Union_t (tbl, tbr, meta2, cmp2) ->\n let* () = type_metadata_eq meta1 meta2 in\n let* Eq = help tal tbl in\n let+ Eq = help tar tbr in\n let Eq = Dependent_bool.merge_dand cmp1 cmp2 in\n (Eq : ((ta, tac) ty, (tb, tbc) ty) eq)\n | Union_t _, _ -> not_equal ()\n | Lambda_t (tal, tar, meta1), Lambda_t (tbl, tbr, meta2) ->\n let* () = type_metadata_eq meta1 meta2 in\n let* Eq = help tal tbl in\n let+ Eq = help tar tbr in\n (Eq : ((ta, tac) ty, (tb, tbc) ty) eq)\n | Lambda_t _, _ -> not_equal ()\n | Contract_t (tal, meta1), Contract_t (tbl, meta2) ->\n let* () = type_metadata_eq meta1 meta2 in\n let+ Eq = help tal tbl in\n (Eq : ((ta, tac) ty, (tb, tbc) ty) eq)\n | Contract_t _, _ -> not_equal ()\n | Option_t (tva, meta1, _), Option_t (tvb, meta2, _) ->\n let* () = type_metadata_eq meta1 meta2 in\n let+ Eq = help tva tvb in\n (Eq : ((ta, tac) ty, (tb, tbc) ty) eq)\n | Option_t _, _ -> not_equal ()\n | List_t (tva, meta1), List_t (tvb, meta2) ->\n let* () = type_metadata_eq meta1 meta2 in\n let+ Eq = help tva tvb in\n (Eq : ((ta, tac) ty, (tb, tbc) ty) eq)\n | List_t _, _ -> not_equal ()\n | Sapling_state_t ms1, Sapling_state_t ms2 ->\n let+ () = memo_size_eq ms1 ms2 in\n Eq\n | Sapling_state_t _, _ -> not_equal ()\n | Sapling_transaction_t ms1, Sapling_transaction_t ms2 ->\n let+ () = memo_size_eq ms1 ms2 in\n Eq\n | Sapling_transaction_t _, _ -> not_equal ()\n | Sapling_transaction_deprecated_t ms1, Sapling_transaction_deprecated_t ms2\n ->\n let+ () = memo_size_eq ms1 ms2 in\n Eq\n | Sapling_transaction_deprecated_t _, _ -> not_equal ()\n | Chest_t, Chest_t -> return Eq\n | Chest_t, _ -> not_equal ()\n | Chest_key_t, Chest_key_t -> return Eq\n | Chest_key_t, _ -> not_equal ()\n in\n help ty1 ty2\n\n(* Same as ty_eq but for stacks.\n A single error monad is used here because there is no need to\n recover from stack merging errors. *)\nlet rec stack_eq :\n type ta tb ts tu.\n Script.location ->\n context ->\n int ->\n (ta, ts) stack_ty ->\n (tb, tu) stack_ty ->\n (((ta, ts) stack_ty, (tb, tu) stack_ty) eq * context) tzresult =\n fun loc ctxt lvl stack1 stack2 ->\n match (stack1, stack2) with\n | Bot_t, Bot_t -> ok (Eq, ctxt)\n | Item_t (ty1, rest1), Item_t (ty2, rest2) ->\n Gas_monad.run ctxt @@ ty_eq ~error_details:(Informative loc) ty1 ty2\n |> record_trace (Bad_stack_item lvl)\n >>? fun (eq, ctxt) ->\n eq >>? fun Eq ->\n stack_eq loc ctxt (lvl + 1) rest1 rest2 >|? fun (Eq, ctxt) ->\n ((Eq : ((ta, ts) stack_ty, (tb, tu) stack_ty) eq), ctxt)\n | _, _ -> error Bad_stack_length\n\n(* ---- Type checker results -------------------------------------------------*)\n\ntype ('a, 's) judgement =\n | Typed : ('a, 's, 'b, 'u) descr -> ('a, 's) judgement\n | Failed : {\n descr : 'b 'u. ('b, 'u) stack_ty -> ('a, 's, 'b, 'u) descr;\n }\n -> ('a, 's) judgement\n\n(* ---- Type checker (Untyped expressions -> Typed IR) ----------------------*)\n\ntype ('a, 's, 'b, 'u, 'c, 'v) branch = {\n branch :\n 'r 'f.\n ('a, 's, 'r, 'f) descr -> ('b, 'u, 'r, 'f) descr -> ('c, 'v, 'r, 'f) descr;\n}\n[@@unboxed]\n\nlet merge_branches :\n type a s b u c v.\n context ->\n Script.location ->\n (a, s) judgement ->\n (b, u) judgement ->\n (a, s, b, u, c, v) branch ->\n ((c, v) judgement * context) tzresult =\n fun ctxt loc btr bfr {branch} ->\n match (btr, bfr) with\n | Typed ({aft = aftbt; _} as dbt), Typed ({aft = aftbf; _} as dbf) ->\n let unmatched_branches () =\n let aftbt = serialize_stack_for_error ctxt aftbt in\n let aftbf = serialize_stack_for_error ctxt aftbf in\n Unmatched_branches (loc, aftbt, aftbf)\n in\n record_trace_eval\n unmatched_branches\n ( stack_eq loc ctxt 1 aftbt aftbf >|? fun (Eq, ctxt) ->\n (Typed (branch dbt dbf), ctxt) )\n | Failed {descr = descrt}, Failed {descr = descrf} ->\n let descr ret = branch (descrt ret) (descrf ret) in\n ok (Failed {descr}, ctxt)\n | Typed dbt, Failed {descr = descrf} ->\n ok (Typed (branch dbt (descrf dbt.aft)), ctxt)\n | Failed {descr = descrt}, Typed dbf ->\n ok (Typed (branch (descrt dbf.aft) dbf), ctxt)\n\nlet parse_memo_size (n : (location, _) Micheline.node) :\n Sapling.Memo_size.t tzresult =\n match n with\n | Int (_, z) -> (\n match Sapling.Memo_size.parse_z z with\n | Ok _ as ok_memo_size -> ok_memo_size\n | Error msg ->\n error\n @@ Invalid_syntactic_constant (location n, strip_locations n, msg))\n | _ -> error @@ Invalid_kind (location n, [Int_kind], kind n)\n\ntype ex_comparable_ty =\n | Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty\n\ntype ex_parameter_ty_and_entrypoints_node =\n | Ex_parameter_ty_and_entrypoints_node : {\n arg_type : ('a, _) ty;\n entrypoints : 'a entrypoints_node;\n }\n -> ex_parameter_ty_and_entrypoints_node\n\n(** [parse_ty] can be used to parse regular types as well as parameter types\n together with their entrypoints.\n\n In the first case, use [~ret:Don't_parse_entrypoints], [parse_ty] will\n return an [ex_ty].\n\n In the second case, use [~ret:Parse_entrypoints], [parse_ty] will return\n an [ex_parameter_ty_and_entrypoints_node].\n*)\ntype ('ret, 'name) parse_ty_ret =\n | Don't_parse_entrypoints : (ex_ty, unit) parse_ty_ret\n | Parse_entrypoints\n : (ex_parameter_ty_and_entrypoints_node, Entrypoint.t option) parse_ty_ret\n\nlet rec parse_ty :\n type ret name.\n context ->\n stack_depth:int ->\n legacy:bool ->\n allow_lazy_storage:bool ->\n allow_operation:bool ->\n allow_contract:bool ->\n allow_ticket:bool ->\n ret:(ret, name) parse_ty_ret ->\n Script.node ->\n (ret * context) tzresult =\n fun ctxt\n ~stack_depth\n ~legacy\n ~allow_lazy_storage\n ~allow_operation\n ~allow_contract\n ~allow_ticket\n ~ret\n node ->\n Gas.consume ctxt Typecheck_costs.parse_type_cycle >>? fun ctxt ->\n if Compare.Int.(stack_depth > 10000) then\n error Typechecking_too_many_recursive_calls\n else\n (match ret with\n | Don't_parse_entrypoints -> ok (node, (() : name))\n | Parse_entrypoints -> extract_entrypoint_annot node)\n >>? fun (node, name) ->\n let return ctxt ty : ret * context =\n match ret with\n | Don't_parse_entrypoints -> (Ex_ty ty, ctxt)\n | Parse_entrypoints ->\n let at_node =\n Option.map (fun name -> {name; original_type_expr = node}) name\n in\n ( Ex_parameter_ty_and_entrypoints_node\n {\n arg_type = ty;\n entrypoints = {at_node; nested = Entrypoints_None};\n },\n ctxt )\n in\n match node with\n | Prim (loc, T_unit, [], annot) ->\n check_type_annot loc annot >|? fun () -> return ctxt unit_t\n | Prim (loc, T_int, [], annot) ->\n check_type_annot loc annot >|? fun () -> return ctxt int_t\n | Prim (loc, T_nat, [], annot) ->\n check_type_annot loc annot >|? fun () -> return ctxt nat_t\n | Prim (loc, T_string, [], annot) ->\n check_type_annot loc annot >|? fun () -> return ctxt string_t\n | Prim (loc, T_bytes, [], annot) ->\n check_type_annot loc annot >|? fun () -> return ctxt bytes_t\n | Prim (loc, T_mutez, [], annot) ->\n check_type_annot loc annot >|? fun () -> return ctxt mutez_t\n | Prim (loc, T_bool, [], annot) ->\n check_type_annot loc annot >|? fun () -> return ctxt bool_t\n | Prim (loc, T_key, [], annot) ->\n check_type_annot loc annot >|? fun () -> return ctxt key_t\n | Prim (loc, T_key_hash, [], annot) ->\n check_type_annot loc annot >|? fun () -> return ctxt key_hash_t\n | Prim (loc, T_chest_key, [], annot) ->\n if legacy then\n check_type_annot loc annot >|? fun () -> return ctxt chest_key_t\n else error (Deprecated_instruction T_chest_key)\n | Prim (loc, T_chest, [], annot) ->\n if legacy then\n check_type_annot loc annot >|? fun () -> return ctxt chest_t\n else error (Deprecated_instruction T_chest)\n | Prim (loc, T_timestamp, [], annot) ->\n check_type_annot loc annot >|? fun () -> return ctxt timestamp_t\n | Prim (loc, T_address, [], annot) ->\n check_type_annot loc annot >|? fun () -> return ctxt address_t\n | Prim (loc, T_tx_rollup_l2_address, [], annot) ->\n if Constants.tx_rollup_enable ctxt || legacy then\n check_type_annot loc annot >|? fun () ->\n return ctxt tx_rollup_l2_address_t\n else error @@ Tx_rollup_addresses_disabled loc\n | Prim (loc, T_signature, [], annot) ->\n check_type_annot loc annot >|? fun () -> return ctxt signature_t\n | Prim (loc, T_operation, [], annot) ->\n if allow_operation then\n check_type_annot loc annot >|? fun () -> return ctxt operation_t\n else error (Unexpected_operation loc)\n | Prim (loc, T_chain_id, [], annot) ->\n check_type_annot loc annot >|? fun () -> return ctxt chain_id_t\n | Prim (loc, T_never, [], annot) ->\n check_type_annot loc annot >|? fun () -> return ctxt never_t\n | Prim (loc, T_bls12_381_g1, [], annot) ->\n check_type_annot loc annot >|? fun () -> return ctxt bls12_381_g1_t\n | Prim (loc, T_bls12_381_g2, [], annot) ->\n check_type_annot loc annot >|? fun () -> return ctxt bls12_381_g2_t\n | Prim (loc, T_bls12_381_fr, [], annot) ->\n check_type_annot loc annot >|? fun () -> return ctxt bls12_381_fr_t\n | Prim (loc, T_contract, [utl], annot) ->\n if allow_contract then\n parse_passable_ty\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy\n utl\n ~ret:Don't_parse_entrypoints\n >>? fun (Ex_ty tl, ctxt) ->\n check_type_annot loc annot >>? fun () ->\n contract_t loc tl >|? fun ty -> return ctxt ty\n else error (Unexpected_contract loc)\n | Prim (loc, T_pair, utl :: utr, annot) ->\n remove_field_annot utl >>? fun utl ->\n parse_ty\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy\n ~allow_lazy_storage\n ~allow_operation\n ~allow_contract\n ~allow_ticket\n ~ret:Don't_parse_entrypoints\n utl\n >>? fun (Ex_ty tl, ctxt) ->\n (match utr with\n | [utr] -> remove_field_annot utr\n | utr ->\n (* Unfold [pair t1 ... tn] as [pair t1 (... (pair tn-1 tn))] *)\n ok (Prim (loc, T_pair, utr, [])))\n >>? fun utr ->\n parse_ty\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy\n ~allow_lazy_storage\n ~allow_operation\n ~allow_contract\n ~allow_ticket\n ~ret:Don't_parse_entrypoints\n utr\n >>? fun (Ex_ty tr, ctxt) ->\n check_type_annot loc annot >>? fun () ->\n pair_t loc tl tr >|? fun (Ty_ex_c ty) -> return ctxt ty\n | Prim (loc, T_or, [utl; utr], annot) -> (\n (match ret with\n | Don't_parse_entrypoints ->\n remove_field_annot utl >>? fun utl ->\n remove_field_annot utr >|? fun utr -> (utl, utr)\n | Parse_entrypoints -> ok (utl, utr))\n >>? fun (utl, utr) ->\n parse_ty\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy\n ~allow_lazy_storage\n ~allow_operation\n ~allow_contract\n ~allow_ticket\n ~ret\n utl\n >>? fun (parsed_l, ctxt) ->\n parse_ty\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy\n ~allow_lazy_storage\n ~allow_operation\n ~allow_contract\n ~allow_ticket\n ~ret\n utr\n >>? fun (parsed_r, ctxt) ->\n check_type_annot loc annot >>? fun () ->\n match ret with\n | Don't_parse_entrypoints ->\n let (Ex_ty tl) = parsed_l in\n let (Ex_ty tr) = parsed_r in\n union_t loc tl tr >|? fun (Ty_ex_c ty) -> ((Ex_ty ty : ret), ctxt)\n | Parse_entrypoints ->\n let (Ex_parameter_ty_and_entrypoints_node\n {arg_type = tl; entrypoints = left}) =\n parsed_l\n in\n let (Ex_parameter_ty_and_entrypoints_node\n {arg_type = tr; entrypoints = right}) =\n parsed_r\n in\n union_t loc tl tr >|? fun (Ty_ex_c arg_type) ->\n let entrypoints =\n let at_node =\n Option.map (fun name -> {name; original_type_expr = node}) name\n in\n {at_node; nested = Entrypoints_Union {left; right}}\n in\n (Ex_parameter_ty_and_entrypoints_node {arg_type; entrypoints}, ctxt)\n )\n | Prim (loc, T_lambda, [uta; utr], annot) ->\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy uta\n >>? fun (Ex_ty ta, ctxt) ->\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy utr\n >>? fun (Ex_ty tr, ctxt) ->\n check_type_annot loc annot >>? fun () ->\n lambda_t loc ta tr >|? fun ty -> return ctxt ty\n | Prim (loc, T_option, [ut], annot) ->\n (if legacy then\n (* legacy semantics with (broken) field annotations *)\n remove_field_annot ut >>? fun ut ->\n check_composed_type_annot loc annot >>? fun () -> ok ut\n else check_type_annot loc annot >>? fun () -> ok ut)\n >>? fun ut ->\n parse_ty\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy\n ~allow_lazy_storage\n ~allow_operation\n ~allow_contract\n ~allow_ticket\n ~ret:Don't_parse_entrypoints\n ut\n >>? fun (Ex_ty t, ctxt) ->\n option_t loc t >|? fun ty -> return ctxt ty\n | Prim (loc, T_list, [ut], annot) ->\n parse_ty\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy\n ~allow_lazy_storage\n ~allow_operation\n ~allow_contract\n ~allow_ticket\n ~ret:Don't_parse_entrypoints\n ut\n >>? fun (Ex_ty t, ctxt) ->\n check_type_annot loc annot >>? fun () ->\n list_t loc t >|? fun ty -> return ctxt ty\n | Prim (loc, T_ticket, [ut], annot) ->\n if allow_ticket then\n parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut\n >>? fun (Ex_comparable_ty t, ctxt) ->\n check_type_annot loc annot >>? fun () ->\n ticket_t loc t >|? fun ty -> return ctxt ty\n else error (Unexpected_ticket loc)\n | Prim (loc, T_set, [ut], annot) ->\n parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut\n >>? fun (Ex_comparable_ty t, ctxt) ->\n check_type_annot loc annot >>? fun () ->\n set_t loc t >|? fun ty -> return ctxt ty\n | Prim (loc, T_map, [uta; utr], annot) ->\n parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt uta\n >>? fun (Ex_comparable_ty ta, ctxt) ->\n parse_ty\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy\n ~allow_lazy_storage\n ~allow_operation\n ~allow_contract\n ~allow_ticket\n ~ret:Don't_parse_entrypoints\n utr\n >>? fun (Ex_ty tr, ctxt) ->\n check_type_annot loc annot >>? fun () ->\n map_t loc ta tr >|? fun ty -> return ctxt ty\n | Prim (loc, T_sapling_transaction, [memo_size], annot) ->\n check_type_annot loc annot >>? fun () ->\n parse_memo_size memo_size >|? fun memo_size ->\n return ctxt (sapling_transaction_t ~memo_size)\n | Prim (loc, T_sapling_transaction_deprecated, [memo_size], annot) ->\n if legacy then\n check_type_annot loc annot >>? fun () ->\n parse_memo_size memo_size >|? fun memo_size ->\n return ctxt (sapling_transaction_deprecated_t ~memo_size)\n else error (Deprecated_instruction T_sapling_transaction_deprecated)\n (*\n /!\\ When adding new lazy storage kinds, be careful to use\n [when allow_lazy_storage] /!\\\n Lazy storage should not be packable to avoid stealing a lazy storage\n from another contract with `PUSH t id` or `UNPACK`.\n *)\n | Prim (loc, T_big_map, args, annot) when allow_lazy_storage ->\n parse_big_map_ty\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy\n loc\n args\n annot\n >|? fun (Ex_ty ty, ctxt) -> return ctxt ty\n | Prim (loc, T_sapling_state, [memo_size], annot) when allow_lazy_storage ->\n check_type_annot loc annot >>? fun () ->\n parse_memo_size memo_size >|? fun memo_size ->\n return ctxt (sapling_state_t ~memo_size)\n | Prim (loc, (T_big_map | T_sapling_state), _, _) ->\n error (Unexpected_lazy_storage loc)\n | Prim\n ( loc,\n (( T_unit | T_signature | T_int | T_nat | T_string | T_bytes | T_mutez\n | T_bool | T_key | T_key_hash | T_timestamp | T_address\n | T_tx_rollup_l2_address | T_chain_id | T_operation | T_never ) as\n prim),\n l,\n _ ) ->\n error (Invalid_arity (loc, prim, 0, List.length l))\n | Prim\n ( loc,\n ((T_set | T_list | T_option | T_contract | T_ticket) as prim),\n l,\n _ ) ->\n error (Invalid_arity (loc, prim, 1, List.length l))\n | Prim (loc, ((T_pair | T_or | T_map | T_lambda) as prim), l, _) ->\n error (Invalid_arity (loc, prim, 2, List.length l))\n | expr ->\n error\n @@ unexpected\n expr\n []\n Type_namespace\n [\n T_bls12_381_fr;\n T_bls12_381_g1;\n T_bls12_381_g2;\n T_bool;\n T_bytes;\n T_chain_id;\n T_contract;\n T_int;\n T_key;\n T_key_hash;\n T_lambda;\n T_list;\n T_map;\n T_mutez;\n T_nat;\n T_never;\n T_operation;\n T_option;\n T_or;\n T_pair;\n T_set;\n T_signature;\n T_string;\n T_ticket;\n T_timestamp;\n T_tx_rollup_l2_address;\n T_unit;\n ]\n\nand parse_comparable_ty :\n context ->\n stack_depth:int ->\n Script.node ->\n (ex_comparable_ty * context) tzresult =\n fun ctxt ~stack_depth node ->\n parse_ty\n ~ret:Don't_parse_entrypoints\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy:false\n ~allow_lazy_storage:false\n ~allow_operation:false\n ~allow_contract:false\n ~allow_ticket:false\n node\n >>? fun (Ex_ty t, ctxt) ->\n match is_comparable t with\n | Yes -> ok (Ex_comparable_ty t, ctxt)\n | No ->\n error\n (Comparable_type_expected (location node, Micheline.strip_locations node))\n\nand parse_passable_ty :\n type ret name.\n context ->\n stack_depth:int ->\n legacy:bool ->\n ret:(ret, name) parse_ty_ret ->\n Script.node ->\n (ret * context) tzresult =\n fun ctxt ~stack_depth ~legacy ->\n (parse_ty [@tailcall])\n ctxt\n ~stack_depth\n ~legacy\n ~allow_lazy_storage:true\n ~allow_operation:false\n ~allow_contract:true\n ~allow_ticket:true\n\nand parse_any_ty :\n context ->\n stack_depth:int ->\n legacy:bool ->\n Script.node ->\n (ex_ty * context) tzresult =\n fun ctxt ~stack_depth ~legacy ->\n (parse_ty [@tailcall])\n ctxt\n ~stack_depth\n ~legacy\n ~allow_lazy_storage:true\n ~allow_operation:true\n ~allow_contract:true\n ~allow_ticket:true\n ~ret:Don't_parse_entrypoints\n\nand parse_big_map_ty ctxt ~stack_depth ~legacy big_map_loc args map_annot =\n Gas.consume ctxt Typecheck_costs.parse_type_cycle >>? fun ctxt ->\n match args with\n | [key_ty; value_ty] ->\n parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt key_ty\n >>? fun (Ex_comparable_ty key_ty, ctxt) ->\n parse_big_map_value_ty\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy\n value_ty\n >>? fun (Ex_ty value_ty, ctxt) ->\n check_type_annot big_map_loc map_annot >>? fun () ->\n big_map_t big_map_loc key_ty value_ty >|? fun big_map_ty ->\n (Ex_ty big_map_ty, ctxt)\n | args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args)\n\nand parse_big_map_value_ty ctxt ~stack_depth ~legacy value_ty =\n (parse_ty [@tailcall])\n ctxt\n ~stack_depth\n ~legacy\n ~allow_lazy_storage:false\n ~allow_operation:false\n ~allow_contract:legacy\n ~allow_ticket:true\n ~ret:Don't_parse_entrypoints\n value_ty\n\nlet parse_packable_ty ctxt ~stack_depth ~legacy node =\n (parse_ty [@tailcall])\n ctxt\n ~stack_depth\n ~legacy\n ~allow_lazy_storage:false\n ~allow_operation:false\n ~allow_contract:legacy\n (* type contract is forbidden in UNPACK because of\n https://gitlab.com/tezos/tezos/-/issues/301 *)\n ~allow_ticket:false\n ~ret:Don't_parse_entrypoints\n node\n\nlet parse_view_input_ty ctxt ~stack_depth ~legacy node =\n (parse_ty [@tailcall])\n ctxt\n ~stack_depth\n ~legacy\n ~allow_lazy_storage:false\n ~allow_operation:false\n ~allow_contract:true\n ~allow_ticket:false\n ~ret:Don't_parse_entrypoints\n node\n\nlet parse_view_output_ty ctxt ~stack_depth ~legacy node =\n (parse_ty [@tailcall])\n ctxt\n ~stack_depth\n ~legacy\n ~allow_lazy_storage:false\n ~allow_operation:false\n ~allow_contract:true\n ~allow_ticket:false\n ~ret:Don't_parse_entrypoints\n node\n\nlet parse_normal_storage_ty ctxt ~stack_depth ~legacy node =\n (parse_ty [@tailcall])\n ctxt\n ~stack_depth\n ~legacy\n ~allow_lazy_storage:true\n ~allow_operation:false\n ~allow_contract:legacy\n ~allow_ticket:true\n ~ret:Don't_parse_entrypoints\n node\n\nlet parse_storage_ty :\n context ->\n stack_depth:int ->\n legacy:bool ->\n Script.node ->\n (ex_ty * context) tzresult =\n fun ctxt ~stack_depth ~legacy node ->\n match node with\n | Prim\n ( loc,\n T_pair,\n [Prim (big_map_loc, T_big_map, args, map_annot); remaining_storage],\n storage_annot )\n when legacy -> (\n match storage_annot with\n | [] ->\n (parse_normal_storage_ty [@tailcall]) ctxt ~stack_depth ~legacy node\n | [single]\n when Compare.Int.(String.length single > 0)\n && Compare.Char.(single.[0] = '%') ->\n (parse_normal_storage_ty [@tailcall]) ctxt ~stack_depth ~legacy node\n | _ ->\n (* legacy semantics of big maps used the wrong annotation parser *)\n Gas.consume ctxt Typecheck_costs.parse_type_cycle >>? fun ctxt ->\n parse_big_map_ty\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy\n big_map_loc\n args\n map_annot\n >>? fun (Ex_ty big_map_ty, ctxt) ->\n parse_normal_storage_ty\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy\n remaining_storage\n >>? fun (Ex_ty remaining_storage, ctxt) ->\n check_composed_type_annot loc storage_annot >>? fun () ->\n pair_t loc big_map_ty remaining_storage >|? fun (Ty_ex_c ty) ->\n (Ex_ty ty, ctxt))\n | _ -> (parse_normal_storage_ty [@tailcall]) ctxt ~stack_depth ~legacy node\n\n(* check_packable: determine if a `ty` is packable into Michelson *)\nlet check_packable ~legacy loc root =\n let rec check : type t tc. (t, tc) ty -> unit tzresult = function\n (* /!\\ When adding new lazy storage kinds, be sure to return an error. /!\\\n Lazy storage should not be packable. *)\n | Big_map_t _ -> error (Unexpected_lazy_storage loc)\n | Sapling_state_t _ -> error (Unexpected_lazy_storage loc)\n | Operation_t -> error (Unexpected_operation loc)\n | Unit_t -> Result.return_unit\n | Int_t -> Result.return_unit\n | Nat_t -> Result.return_unit\n | Signature_t -> Result.return_unit\n | String_t -> Result.return_unit\n | Bytes_t -> Result.return_unit\n | Mutez_t -> Result.return_unit\n | Key_hash_t -> Result.return_unit\n | Key_t -> Result.return_unit\n | Timestamp_t -> Result.return_unit\n | Address_t -> Result.return_unit\n | Tx_rollup_l2_address_t -> Result.return_unit\n | Bool_t -> Result.return_unit\n | Chain_id_t -> Result.return_unit\n | Never_t -> Result.return_unit\n | Set_t (_, _) -> Result.return_unit\n | Ticket_t _ -> error (Unexpected_ticket loc)\n | Lambda_t (_, _, _) -> Result.return_unit\n | Bls12_381_g1_t -> Result.return_unit\n | Bls12_381_g2_t -> Result.return_unit\n | Bls12_381_fr_t -> Result.return_unit\n | Pair_t (l_ty, r_ty, _, _) -> check l_ty >>? fun () -> check r_ty\n | Union_t (l_ty, r_ty, _, _) -> check l_ty >>? fun () -> check r_ty\n | Option_t (v_ty, _, _) -> check v_ty\n | List_t (elt_ty, _) -> check elt_ty\n | Map_t (_, elt_ty, _) -> check elt_ty\n | Contract_t (_, _) when legacy -> Result.return_unit\n | Contract_t (_, _) -> error (Unexpected_contract loc)\n | Sapling_transaction_t _ -> ok ()\n | Sapling_transaction_deprecated_t _ -> ok ()\n | Chest_key_t -> Result.return_unit\n | Chest_t -> Result.return_unit\n in\n check root\n\ntype toplevel = {\n code_field : Script.node;\n arg_type : Script.node;\n storage_type : Script.node;\n views : view_map;\n}\n\ntype ('arg, 'storage) code =\n | Code : {\n code :\n (('arg, 'storage) pair, (operation Script_list.t, 'storage) pair) lambda;\n arg_type : ('arg, _) ty;\n storage_type : ('storage, _) ty;\n views : view_map;\n entrypoints : 'arg entrypoints;\n code_size : Cache_memory_helpers.sint;\n }\n -> ('arg, 'storage) code\n\ntype ex_script = Ex_script : ('a, 'c) Script_typed_ir.script -> ex_script\n\ntype ex_code = Ex_code : ('a, 'c) code -> ex_code\n\ntype 'storage typed_view =\n | Typed_view : {\n input_ty : ('input, _) ty;\n output_ty : ('output, _) ty;\n kinstr : ('input * 'storage, end_of_stack, 'output, end_of_stack) kinstr;\n original_code_expr : Script.node;\n }\n -> 'storage typed_view\n\ntype 'storage typed_view_map = (Script_string.t, 'storage typed_view) map\n\ntype (_, _) dig_proof_argument =\n | Dig_proof_argument :\n ('x, 'a * 's, 'a, 's, 'b, 't, 'c, 'u) stack_prefix_preservation_witness\n * ('x, _) ty\n * ('c, 'u) stack_ty\n -> ('b, 't) dig_proof_argument\n\ntype (_, _, _) dug_proof_argument =\n | Dug_proof_argument :\n (('a, 's, 'x, 'a * 's, 'b, 't, 'c, 'u) stack_prefix_preservation_witness\n * ('c, 'u) stack_ty)\n -> ('b, 't, 'x) dug_proof_argument\n\ntype (_, _) dipn_proof_argument =\n | Dipn_proof_argument :\n ('fa, 'fs, 'fb, 'fu, 'a, 's, 'b, 'u) stack_prefix_preservation_witness\n * context\n * ('fa, 'fs, 'fb, 'fu) descr\n * ('b, 'u) stack_ty\n -> ('a, 's) dipn_proof_argument\n\ntype (_, _) dropn_proof_argument =\n | Dropn_proof_argument :\n ('fa, 'fs, 'fa, 'fs, 'a, 's, 'a, 's) stack_prefix_preservation_witness\n * ('fa, 'fs) stack_ty\n -> ('a, 's) dropn_proof_argument\n\ntype (_, _, _) comb_proof_argument =\n | Comb_proof_argument :\n ('a, 'b, 's, 'c, 'd, 't) comb_gadt_witness * ('c, 'd * 't) stack_ty\n -> ('a, 'b, 's) comb_proof_argument\n\ntype (_, _, _) uncomb_proof_argument =\n | Uncomb_proof_argument :\n ('a, 'b, 's, 'c, 'd, 't) uncomb_gadt_witness * ('c, 'd * 't) stack_ty\n -> ('a, 'b, 's) uncomb_proof_argument\n\ntype 'before comb_get_proof_argument =\n | Comb_get_proof_argument :\n ('before, 'after) comb_get_gadt_witness * ('after, _) ty\n -> 'before comb_get_proof_argument\n\ntype ('rest, 'before) comb_set_proof_argument =\n | Comb_set_proof_argument :\n ('rest, 'before, 'after) comb_set_gadt_witness * ('after, _) ty\n -> ('rest, 'before) comb_set_proof_argument\n\ntype (_, _, _) dup_n_proof_argument =\n | Dup_n_proof_argument :\n ('a, 'b, 's, 't) dup_n_gadt_witness * ('t, _) ty\n -> ('a, 'b, 's) dup_n_proof_argument\n\nlet rec make_dug_proof_argument :\n type a s x xc.\n location ->\n int ->\n (x, xc) ty ->\n (a, s) stack_ty ->\n (a, s, x) dug_proof_argument option =\n fun loc n x stk ->\n match (n, stk) with\n | 0, rest -> Some (Dug_proof_argument (KRest, Item_t (x, rest)))\n | n, Item_t (v, rest) ->\n make_dug_proof_argument loc (n - 1) x rest\n |> Option.map @@ fun (Dug_proof_argument (n', aft')) ->\n Dug_proof_argument (KPrefix (loc, v, n'), Item_t (v, aft'))\n | _, _ -> None\n\nlet rec make_comb_get_proof_argument :\n type b bc. int -> (b, bc) ty -> b comb_get_proof_argument option =\n fun n ty ->\n match (n, ty) with\n | 0, value_ty -> Some (Comb_get_proof_argument (Comb_get_zero, value_ty))\n | 1, Pair_t (hd_ty, _, _annot, _) ->\n Some (Comb_get_proof_argument (Comb_get_one, hd_ty))\n | n, Pair_t (_, tl_ty, _annot, _) ->\n make_comb_get_proof_argument (n - 2) tl_ty\n |> Option.map\n @@ fun (Comb_get_proof_argument (comb_get_left_witness, ty')) ->\n Comb_get_proof_argument (Comb_get_plus_two comb_get_left_witness, ty')\n | _ -> None\n\nlet rec make_comb_set_proof_argument :\n type value valuec before beforec a s.\n context ->\n (a, s) stack_ty ->\n location ->\n int ->\n (value, valuec) ty ->\n (before, beforec) ty ->\n (value, before) comb_set_proof_argument tzresult =\n fun ctxt stack_ty loc n value_ty ty ->\n match (n, ty) with\n | 0, _ -> ok @@ Comb_set_proof_argument (Comb_set_zero, value_ty)\n | 1, Pair_t (_hd_ty, tl_ty, _, _) ->\n pair_t loc value_ty tl_ty >|? fun (Ty_ex_c after_ty) ->\n Comb_set_proof_argument (Comb_set_one, after_ty)\n | n, Pair_t (hd_ty, tl_ty, _, _) ->\n make_comb_set_proof_argument ctxt stack_ty loc (n - 2) value_ty tl_ty\n >>? fun (Comb_set_proof_argument (comb_set_left_witness, tl_ty')) ->\n pair_t loc hd_ty tl_ty' >|? fun (Ty_ex_c after_ty) ->\n Comb_set_proof_argument (Comb_set_plus_two comb_set_left_witness, after_ty)\n | _ ->\n let whole_stack = serialize_stack_for_error ctxt stack_ty in\n error (Bad_stack (loc, I_UPDATE, 2, whole_stack))\n\ntype 'a ex_ty_cstr =\n | Ex_ty_cstr : {\n ty : ('b, _) Script_typed_ir.ty;\n construct : 'b -> 'a;\n original_type_expr : Script.node;\n }\n -> 'a ex_ty_cstr\n\nlet find_entrypoint (type full fullc error_context error_trace)\n ~(error_details : (error_context, error_trace) error_details)\n (full : (full, fullc) ty) (entrypoints : full entrypoints) entrypoint :\n (full ex_ty_cstr, error_trace) Gas_monad.t =\n let open Gas_monad.Syntax in\n let rec find_entrypoint :\n type t tc.\n (t, tc) ty ->\n t entrypoints_node ->\n Entrypoint.t ->\n (t ex_ty_cstr, unit) Gas_monad.t =\n fun ty entrypoints entrypoint ->\n let* () = Gas_monad.consume_gas Typecheck_costs.find_entrypoint_cycle in\n match (ty, entrypoints) with\n | _, {at_node = Some {name; original_type_expr}; _}\n when Entrypoint.(name = entrypoint) ->\n return (Ex_ty_cstr {ty; construct = (fun e -> e); original_type_expr})\n | Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _} -> (\n Gas_monad.bind_recover (find_entrypoint tl left entrypoint) @@ function\n | Ok (Ex_ty_cstr {ty; construct; original_type_expr}) ->\n return\n (Ex_ty_cstr\n {\n ty;\n construct = (fun e -> L (construct e));\n original_type_expr;\n })\n | Error () ->\n let+ (Ex_ty_cstr {ty; construct; original_type_expr}) =\n find_entrypoint tr right entrypoint\n in\n Ex_ty_cstr\n {ty; construct = (fun e -> R (construct e)); original_type_expr})\n | _, {nested = Entrypoints_None; _} -> Gas_monad.of_result (Error ())\n in\n let {root; original_type_expr} = entrypoints in\n Gas_monad.bind_recover (find_entrypoint full root entrypoint) @@ function\n | Ok f_t -> return f_t\n | Error () ->\n if Entrypoint.is_default entrypoint then\n return\n (Ex_ty_cstr {ty = full; construct = (fun e -> e); original_type_expr})\n else\n Gas_monad.of_result\n @@ Error\n (match error_details with\n | Fast -> (Inconsistent_types_fast : error_trace)\n | Informative _ -> trace_of_error @@ No_such_entrypoint entrypoint)\n\nlet find_entrypoint_for_type (type full fullc exp expc error_trace)\n ~error_details ~(full : (full, fullc) ty) ~(expected : (exp, expc) ty)\n entrypoints entrypoint :\n (Entrypoint.t * (exp, expc) ty, error_trace) Gas_monad.t =\n let open Gas_monad.Syntax in\n let* res = find_entrypoint ~error_details full entrypoints entrypoint in\n match res with\n | Ex_ty_cstr {ty; _} -> (\n match entrypoints.root.at_node with\n | Some {name; original_type_expr = _}\n when Entrypoint.is_root name && Entrypoint.is_default entrypoint ->\n Gas_monad.bind_recover\n (ty_eq ~error_details:Fast ty expected)\n (function\n | Ok Eq -> return (Entrypoint.default, (ty : (exp, expc) ty))\n | Error Inconsistent_types_fast ->\n let+ Eq = ty_eq ~error_details full expected in\n (Entrypoint.root, (full : (exp, expc) ty)))\n | _ ->\n let+ Eq = ty_eq ~error_details ty expected in\n (entrypoint, (ty : (exp, expc) ty)))\n\nlet well_formed_entrypoints (type full fullc) (full : (full, fullc) ty)\n entrypoints =\n let merge path (type t tc) (ty : (t, tc) ty)\n (entrypoints : t entrypoints_node) reachable\n ((first_unreachable, all) as acc) =\n match entrypoints.at_node with\n | None ->\n ok\n ( (if reachable then acc\n else\n match ty with\n | Union_t _ -> acc\n | _ -> (\n match first_unreachable with\n | None -> (Some (List.rev path), all)\n | Some _ -> acc)),\n reachable )\n | Some {name; original_type_expr = _} ->\n if Entrypoint.Set.mem name all then error (Duplicate_entrypoint name)\n else ok ((first_unreachable, Entrypoint.Set.add name all), true)\n in\n let rec check :\n type t tc.\n (t, tc) ty ->\n t entrypoints_node ->\n prim list ->\n bool ->\n prim list option * Entrypoint.Set.t ->\n (prim list option * Entrypoint.Set.t) tzresult =\n fun t entrypoints path reachable acc ->\n match (t, entrypoints) with\n | Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _} ->\n merge (D_Left :: path) tl left reachable acc\n >>? fun (acc, l_reachable) ->\n merge (D_Right :: path) tr right reachable acc\n >>? fun (acc, r_reachable) ->\n check tl left (D_Left :: path) l_reachable acc >>? fun acc ->\n check tr right (D_Right :: path) r_reachable acc\n | _ -> ok acc\n in\n let init, reachable =\n match entrypoints.at_node with\n | None -> (Entrypoint.Set.empty, false)\n | Some {name; original_type_expr = _} ->\n (Entrypoint.Set.singleton name, true)\n in\n check full entrypoints [] reachable (None, init)\n >>? fun (first_unreachable, all) ->\n if not (Entrypoint.Set.mem Entrypoint.default all) then Result.return_unit\n else\n match first_unreachable with\n | None -> Result.return_unit\n | Some path -> error (Unreachable_entrypoint path)\n\ntype ex_parameter_ty_and_entrypoints =\n | Ex_parameter_ty_and_entrypoints : {\n arg_type : ('a, _) ty;\n entrypoints : 'a entrypoints;\n }\n -> ex_parameter_ty_and_entrypoints\n\nlet parse_parameter_ty_and_entrypoints :\n context ->\n stack_depth:int ->\n legacy:bool ->\n Script.node ->\n (ex_parameter_ty_and_entrypoints * context) tzresult =\n fun ctxt ~stack_depth ~legacy node ->\n parse_passable_ty\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy\n node\n ~ret:Parse_entrypoints\n >>? fun (Ex_parameter_ty_and_entrypoints_node {arg_type; entrypoints}, ctxt)\n ->\n (if legacy then Result.return_unit\n else well_formed_entrypoints arg_type entrypoints)\n >|? fun () ->\n let entrypoints = {root = entrypoints; original_type_expr = node} in\n (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt)\n\nlet parse_passable_ty = parse_passable_ty ~ret:Don't_parse_entrypoints\n\nlet parse_uint ~nb_bits =\n assert (Compare.Int.(nb_bits >= 0 && nb_bits <= 30)) ;\n let max_int = (1 lsl nb_bits) - 1 in\n let max_z = Z.of_int max_int in\n function\n | Micheline.Int (_, n) when Compare.Z.(Z.zero <= n) && Compare.Z.(n <= max_z)\n ->\n ok (Z.to_int n)\n | node ->\n error\n @@ Invalid_syntactic_constant\n ( location node,\n strip_locations node,\n \"a positive \" ^ string_of_int nb_bits\n ^ \"-bit integer (between 0 and \" ^ string_of_int max_int ^ \")\" )\n\nlet parse_uint10 = parse_uint ~nb_bits:10\n\nlet parse_uint11 = parse_uint ~nb_bits:11\n\n(* The type returned by this function is used to:\n - serialize and deserialize tickets when they are stored or transferred,\n - type the READ_TICKET instruction. *)\nlet opened_ticket_type loc ty = comparable_pair_3_t loc address_t ty nat_t\n\n(* -- parse data of primitive types -- *)\n\nlet parse_unit ctxt ~legacy = function\n | Prim (loc, D_Unit, [], annot) ->\n (if legacy then Result.return_unit else error_unexpected_annot loc annot)\n >>? fun () ->\n Gas.consume ctxt Typecheck_costs.unit >|? fun ctxt -> ((), ctxt)\n | Prim (loc, D_Unit, l, _) ->\n error @@ Invalid_arity (loc, D_Unit, 0, List.length l)\n | expr -> error @@ unexpected expr [] Constant_namespace [D_Unit]\n\nlet parse_bool ctxt ~legacy = function\n | Prim (loc, D_True, [], annot) ->\n (if legacy then Result.return_unit else error_unexpected_annot loc annot)\n >>? fun () ->\n Gas.consume ctxt Typecheck_costs.bool >|? fun ctxt -> (true, ctxt)\n | Prim (loc, D_False, [], annot) ->\n (if legacy then Result.return_unit else error_unexpected_annot loc annot)\n >>? fun () ->\n Gas.consume ctxt Typecheck_costs.bool >|? fun ctxt -> (false, ctxt)\n | Prim (loc, ((D_True | D_False) as c), l, _) ->\n error @@ Invalid_arity (loc, c, 0, List.length l)\n | expr -> error @@ unexpected expr [] Constant_namespace [D_True; D_False]\n\nlet parse_string ctxt : Script.node -> (Script_string.t * context) tzresult =\n function\n | String (loc, v) as expr ->\n Gas.consume ctxt (Typecheck_costs.check_printable v) >>? fun ctxt ->\n record_trace\n (Invalid_syntactic_constant\n (loc, strip_locations expr, \"a printable ascii string\"))\n (Script_string.of_string v >|? fun s -> (s, ctxt))\n | expr -> error @@ Invalid_kind (location expr, [String_kind], kind expr)\n\nlet parse_bytes ctxt = function\n | Bytes (_, v) -> ok (v, ctxt)\n | expr -> error @@ Invalid_kind (location expr, [Bytes_kind], kind expr)\n\nlet parse_int ctxt = function\n | Int (_, v) -> ok (Script_int.of_zint v, ctxt)\n | expr -> error @@ Invalid_kind (location expr, [Int_kind], kind expr)\n\nlet parse_nat ctxt :\n Script.node -> (Script_int.n Script_int.num * context) tzresult = function\n | Int (loc, v) as expr -> (\n let v = Script_int.of_zint v in\n match Script_int.is_nat v with\n | Some nat -> ok (nat, ctxt)\n | None ->\n error\n @@ Invalid_syntactic_constant\n (loc, strip_locations expr, \"a non-negative integer\"))\n | expr -> error @@ Invalid_kind (location expr, [Int_kind], kind expr)\n\nlet parse_mutez ctxt : Script.node -> (Tez.t * context) tzresult = function\n | Int (loc, v) as expr -> (\n match\n let open Option in\n bind (catch (fun () -> Z.to_int64 v)) Tez.of_mutez\n with\n | Some tez -> Ok (tez, ctxt)\n | None ->\n error\n @@ Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid mutez amount\"))\n | expr -> error @@ Invalid_kind (location expr, [Int_kind], kind expr)\n\nlet parse_timestamp ctxt :\n Script.node -> (Script_timestamp.t * context) tzresult = function\n | Int (_, v) (* As unparsed with [Optimized] or out of bounds [Readable]. *)\n ->\n ok (Script_timestamp.of_zint v, ctxt)\n | String (loc, s) as expr (* As unparsed with [Readable]. *) -> (\n Gas.consume ctxt (Typecheck_costs.timestamp_readable s) >>? fun ctxt ->\n match Script_timestamp.of_string s with\n | Some v -> ok (v, ctxt)\n | None ->\n error\n @@ Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid timestamp\"))\n | expr ->\n error @@ Invalid_kind (location expr, [String_kind; Int_kind], kind expr)\n\nlet parse_key ctxt : Script.node -> (public_key * context) tzresult = function\n | Bytes (loc, bytes) as expr -> (\n (* As unparsed with [Optimized]. *)\n Gas.consume ctxt Typecheck_costs.public_key_optimized\n >>? fun ctxt ->\n match\n Data_encoding.Binary.of_bytes_opt Signature.Public_key.encoding bytes\n with\n | Some k -> ok (k, ctxt)\n | None ->\n error\n @@ Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid public key\"))\n | String (loc, s) as expr -> (\n (* As unparsed with [Readable]. *)\n Gas.consume ctxt Typecheck_costs.public_key_readable\n >>? fun ctxt ->\n match Signature.Public_key.of_b58check_opt s with\n | Some k -> ok (k, ctxt)\n | None ->\n error\n @@ Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid public key\"))\n | expr ->\n error @@ Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)\n\nlet parse_key_hash ctxt : Script.node -> (public_key_hash * context) tzresult =\n function\n | Bytes (loc, bytes) as expr -> (\n (* As unparsed with [Optimized]. *)\n Gas.consume ctxt Typecheck_costs.key_hash_optimized\n >>? fun ctxt ->\n match\n Data_encoding.Binary.of_bytes_opt\n Signature.Public_key_hash.encoding\n bytes\n with\n | Some k -> ok (k, ctxt)\n | None ->\n error\n @@ Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid key hash\"))\n | String (loc, s) as expr (* As unparsed with [Readable]. *) -> (\n Gas.consume ctxt Typecheck_costs.key_hash_readable >>? fun ctxt ->\n match Signature.Public_key_hash.of_b58check_opt s with\n | Some k -> ok (k, ctxt)\n | None ->\n error\n @@ Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid key hash\"))\n | expr ->\n error @@ Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)\n\nlet parse_signature ctxt : Script.node -> (signature * context) tzresult =\n function\n | Bytes (loc, bytes) as expr (* As unparsed with [Optimized]. *) -> (\n Gas.consume ctxt Typecheck_costs.signature_optimized >>? fun ctxt ->\n match\n Data_encoding.Binary.of_bytes_opt Script_signature.encoding bytes\n with\n | Some k -> ok (k, ctxt)\n | None ->\n error\n @@ Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid signature\"))\n | String (loc, s) as expr (* As unparsed with [Readable]. *) -> (\n Gas.consume ctxt Typecheck_costs.signature_readable >>? fun ctxt ->\n match Script_signature.of_b58check_opt s with\n | Some s -> ok (s, ctxt)\n | None ->\n error\n @@ Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid signature\"))\n | expr ->\n error @@ Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)\n\nlet parse_chain_id ctxt : Script.node -> (Script_chain_id.t * context) tzresult\n = function\n | Bytes (loc, bytes) as expr -> (\n Gas.consume ctxt Typecheck_costs.chain_id_optimized >>? fun ctxt ->\n match\n Data_encoding.Binary.of_bytes_opt Script_chain_id.encoding bytes\n with\n | Some k -> ok (k, ctxt)\n | None ->\n error\n @@ Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid chain id\"))\n | String (loc, s) as expr -> (\n Gas.consume ctxt Typecheck_costs.chain_id_readable >>? fun ctxt ->\n match Script_chain_id.of_b58check_opt s with\n | Some s -> ok (s, ctxt)\n | None ->\n error\n @@ Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid chain id\"))\n | expr ->\n error @@ Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)\n\nlet parse_address ctxt : Script.node -> (address * context) tzresult =\n let destination_allowed loc {destination; entrypoint} ctxt =\n match destination with\n | Destination.Tx_rollup _ when not (Constants.tx_rollup_enable ctxt) ->\n error @@ Tx_rollup_addresses_disabled loc\n | Destination.Sc_rollup _ when not (Constants.sc_rollup_enable ctxt) ->\n error @@ Sc_rollup_disabled loc\n | Destination.Zk_rollup _ when not (Constants.zk_rollup_enable ctxt) ->\n error @@ Zk_rollup_disabled loc\n | _ -> Ok ({destination; entrypoint}, ctxt)\n in\n function\n | Bytes (loc, bytes) as expr (* As unparsed with [Optimized]. *) -> (\n Gas.consume ctxt Typecheck_costs.contract_optimized >>? fun ctxt ->\n match\n Data_encoding.Binary.of_bytes_opt\n Data_encoding.(tup2 Destination.encoding Entrypoint.value_encoding)\n bytes\n with\n | Some (destination, entrypoint) ->\n destination_allowed loc {destination; entrypoint} ctxt\n | None ->\n error\n @@ Invalid_syntactic_constant\n (loc, strip_locations expr, \"a valid address\"))\n | String (loc, s) (* As unparsed with [Readable]. *) ->\n Gas.consume ctxt Typecheck_costs.contract_readable >>? fun ctxt ->\n (match String.index_opt s '%' with\n | None -> ok (s, Entrypoint.default)\n | Some pos ->\n let len = String.length s - pos - 1 in\n let name = String.sub s (pos + 1) len in\n Entrypoint.of_string_strict ~loc name >|? fun entrypoint ->\n (String.sub s 0 pos, entrypoint))\n >>? fun (addr, entrypoint) ->\n Destination.of_b58check addr >>? fun destination ->\n destination_allowed loc {destination; entrypoint} ctxt\n | expr ->\n error @@ Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)\n\nlet parse_tx_rollup_l2_address ctxt :\n Script.node -> (tx_rollup_l2_address * context) tzresult = function\n | Bytes (loc, bytes) as expr (* As unparsed with [Optimized]. *) -> (\n Gas.consume ctxt Typecheck_costs.tx_rollup_l2_address >>? fun ctxt ->\n match Tx_rollup_l2_address.of_bytes_opt bytes with\n | Some txa -> ok (Tx_rollup_l2_address.Indexable.value txa, ctxt)\n | None ->\n error\n @@ Invalid_syntactic_constant\n ( loc,\n strip_locations expr,\n \"a valid transaction rollup L2 address\" ))\n | String (loc, str) as expr (* As unparsed with [Readable]. *) -> (\n Gas.consume ctxt Typecheck_costs.tx_rollup_l2_address >>? fun ctxt ->\n match Tx_rollup_l2_address.of_b58check_opt str with\n | Some txa -> ok (Tx_rollup_l2_address.Indexable.value txa, ctxt)\n | None ->\n error\n @@ Invalid_syntactic_constant\n ( loc,\n strip_locations expr,\n \"a valid transaction rollup L2 address\" ))\n | expr ->\n error @@ Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)\n\nlet parse_never expr : (never * context) tzresult =\n error @@ Invalid_never_expr (location expr)\n\n(* -- parse data of complex types -- *)\n\nlet parse_pair (type r) parse_l parse_r ctxt ~legacy\n (r_comb_witness : (r, unit -> _) comb_witness) expr =\n let parse_comb loc l rs =\n parse_l ctxt l >>=? fun (l, ctxt) ->\n (match (rs, r_comb_witness) with\n | [r], _ -> ok r\n | [], _ -> error @@ Invalid_arity (loc, D_Pair, 2, 1)\n | _ :: _, Comb_Pair _ ->\n (* Unfold [Pair x1 ... xn] as [Pair x1 (Pair x2 ... xn-1 xn))]\n for type [pair ta (pair tb1 tb2)] and n >= 3 only *)\n ok (Prim (loc, D_Pair, rs, []))\n | _ -> error @@ Invalid_arity (loc, D_Pair, 2, 1 + List.length rs))\n >>?= fun r ->\n parse_r ctxt r >|=? fun (r, ctxt) -> ((l, r), ctxt)\n in\n match expr with\n | Prim (loc, D_Pair, l :: rs, annot) ->\n (if legacy then Result.return_unit else error_unexpected_annot loc annot)\n >>?= fun () -> parse_comb loc l rs\n | Prim (loc, D_Pair, l, _) ->\n tzfail @@ Invalid_arity (loc, D_Pair, 2, List.length l)\n (* Unfold [{x1; ...; xn}] as [Pair x1 x2 ... xn-1 xn] for n >= 2 *)\n | Seq (loc, l :: (_ :: _ as rs)) -> parse_comb loc l rs\n | Seq (loc, l) -> tzfail @@ Invalid_seq_arity (loc, 2, List.length l)\n | expr -> tzfail @@ unexpected expr [] Constant_namespace [D_Pair]\n\nlet parse_union parse_l parse_r ctxt ~legacy = function\n | Prim (loc, D_Left, [v], annot) ->\n (if legacy then Result.return_unit else error_unexpected_annot loc annot)\n >>?= fun () ->\n parse_l ctxt v >|=? fun (v, ctxt) -> (L v, ctxt)\n | Prim (loc, D_Left, l, _) ->\n tzfail @@ Invalid_arity (loc, D_Left, 1, List.length l)\n | Prim (loc, D_Right, [v], annot) ->\n (if legacy then Result.return_unit else error_unexpected_annot loc annot)\n >>?= fun () ->\n parse_r ctxt v >|=? fun (v, ctxt) -> (R v, ctxt)\n | Prim (loc, D_Right, l, _) ->\n tzfail @@ Invalid_arity (loc, D_Right, 1, List.length l)\n | expr -> tzfail @@ unexpected expr [] Constant_namespace [D_Left; D_Right]\n\nlet parse_option parse_v ctxt ~legacy = function\n | Prim (loc, D_Some, [v], annot) ->\n (if legacy then Result.return_unit else error_unexpected_annot loc annot)\n >>?= fun () ->\n parse_v ctxt v >|=? fun (v, ctxt) -> (Some v, ctxt)\n | Prim (loc, D_Some, l, _) ->\n tzfail @@ Invalid_arity (loc, D_Some, 1, List.length l)\n | Prim (loc, D_None, [], annot) ->\n Lwt.return\n ( (if legacy then Result.return_unit\n else error_unexpected_annot loc annot)\n >|? fun () -> (None, ctxt) )\n | Prim (loc, D_None, l, _) ->\n tzfail @@ Invalid_arity (loc, D_None, 0, List.length l)\n | expr -> tzfail @@ unexpected expr [] Constant_namespace [D_Some; D_None]\n\nlet comb_witness1 : type t tc. (t, tc) ty -> (t, unit -> unit) comb_witness =\n function\n | Pair_t _ -> Comb_Pair Comb_Any\n | _ -> Comb_Any\n\nlet parse_view_name ctxt : Script.node -> (Script_string.t * context) tzresult =\n function\n | String (loc, v) as expr ->\n (* The limitation of length of string is same as entrypoint *)\n if Compare.Int.(String.length v > 31) then error (View_name_too_long v)\n else\n let rec check_char i =\n if Compare.Int.(i < 0) then ok v\n else if Script_ir_annot.is_allowed_char v.[i] then check_char (i - 1)\n else error (Bad_view_name loc)\n in\n Gas.consume ctxt (Typecheck_costs.check_printable v) >>? fun ctxt ->\n record_trace\n (Invalid_syntactic_constant\n ( loc,\n strip_locations expr,\n \"string [a-zA-Z0-9_.%@] and the maximum string length of 31 \\\n characters\" ))\n ( check_char (String.length v - 1) >>? fun v ->\n Script_string.of_string v >|? fun s -> (s, ctxt) )\n | expr -> error @@ Invalid_kind (location expr, [String_kind], kind expr)\n\nlet parse_toplevel :\n context -> legacy:bool -> Script.expr -> (toplevel * context) tzresult =\n fun ctxt ~legacy toplevel ->\n record_trace (Ill_typed_contract (toplevel, []))\n @@\n match root toplevel with\n | Int (loc, _) -> error (Invalid_kind (loc, [Seq_kind], Int_kind))\n | String (loc, _) -> error (Invalid_kind (loc, [Seq_kind], String_kind))\n | Bytes (loc, _) -> error (Invalid_kind (loc, [Seq_kind], Bytes_kind))\n | Prim (loc, _, _, _) -> error (Invalid_kind (loc, [Seq_kind], Prim_kind))\n | Seq (_, fields) -> (\n let rec find_fields ctxt p s c views fields =\n match fields with\n | [] -> ok (ctxt, (p, s, c, views))\n | Int (loc, _) :: _ -> error (Invalid_kind (loc, [Prim_kind], Int_kind))\n | String (loc, _) :: _ ->\n error (Invalid_kind (loc, [Prim_kind], String_kind))\n | Bytes (loc, _) :: _ ->\n error (Invalid_kind (loc, [Prim_kind], Bytes_kind))\n | Seq (loc, _) :: _ -> error (Invalid_kind (loc, [Prim_kind], Seq_kind))\n | Prim (loc, K_parameter, [arg], annot) :: rest -> (\n match p with\n | None -> find_fields ctxt (Some (arg, loc, annot)) s c views rest\n | Some _ -> error (Duplicate_field (loc, K_parameter)))\n | Prim (loc, K_storage, [arg], annot) :: rest -> (\n match s with\n | None -> find_fields ctxt p (Some (arg, loc, annot)) c views rest\n | Some _ -> error (Duplicate_field (loc, K_storage)))\n | Prim (loc, K_code, [arg], annot) :: rest -> (\n match c with\n | None -> find_fields ctxt p s (Some (arg, loc, annot)) views rest\n | Some _ -> error (Duplicate_field (loc, K_code)))\n | Prim (loc, ((K_parameter | K_storage | K_code) as name), args, _) :: _\n ->\n error (Invalid_arity (loc, name, 1, List.length args))\n | Prim (loc, K_view, [name; input_ty; output_ty; view_code], _) :: rest\n ->\n parse_view_name ctxt name >>? fun (str, ctxt) ->\n Gas.consume\n ctxt\n (Michelson_v1_gas.Cost_of.Interpreter.view_update str views)\n >>? fun ctxt ->\n if Script_map.mem str views then error (Duplicated_view_name loc)\n else\n let views' =\n Script_map.update\n str\n (Some {input_ty; output_ty; view_code})\n views\n in\n find_fields ctxt p s c views' rest\n | Prim (loc, K_view, args, _) :: _ ->\n error (Invalid_arity (loc, K_view, 4, List.length args))\n | Prim (loc, name, _, _) :: _ ->\n let allowed = [K_parameter; K_storage; K_code; K_view] in\n error (Invalid_primitive (loc, allowed, name))\n in\n find_fields ctxt None None None (Script_map.empty string_t) fields\n >>? fun (ctxt, toplevel) ->\n match toplevel with\n | None, _, _, _ -> error (Missing_field K_parameter)\n | Some _, None, _, _ -> error (Missing_field K_storage)\n | Some _, Some _, None, _ -> error (Missing_field K_code)\n | ( Some (p, ploc, pannot),\n Some (s, sloc, sannot),\n Some (c, cloc, cannot),\n views ) ->\n let p_pannot =\n (* root name can be attached to either the parameter\n primitive or the toplevel constructor (legacy only).\n\n In the latter case we move it to the parameter type.\n *)\n Script_ir_annot.has_field_annot p >>? function\n | true -> ok (p, pannot)\n | false -> (\n match pannot with\n | [single] when legacy -> (\n is_field_annot ploc single >|? fun is_field_annot ->\n match (is_field_annot, p) with\n | true, Prim (loc, prim, args, annots) ->\n (Prim (loc, prim, args, single :: annots), [])\n | _ -> (p, []))\n | _ -> ok (p, pannot))\n in\n (* only one field annot is allowed to set the root entrypoint name *)\n p_pannot >>? fun (arg_type, pannot) ->\n Script_ir_annot.error_unexpected_annot ploc pannot >>? fun () ->\n Script_ir_annot.error_unexpected_annot cloc cannot >>? fun () ->\n Script_ir_annot.error_unexpected_annot sloc sannot >|? fun () ->\n ({code_field = c; arg_type; views; storage_type = s}, ctxt))\n\n(* Normalize lambdas during parsing *)\n\nlet normalized_lam ~unparse_code_rec ~stack_depth ctxt kdescr code_field =\n unparse_code_rec ctxt ~stack_depth:(stack_depth + 1) Optimized code_field\n >|=? fun (code_field, ctxt) -> (Lam (kdescr, code_field), ctxt)\n\nlet normalized_lam_rec ~unparse_code_rec ~stack_depth ctxt kdescr code_field =\n unparse_code_rec ctxt ~stack_depth:(stack_depth + 1) Optimized code_field\n >|=? fun (code_field, ctxt) -> (LamRec (kdescr, code_field), ctxt)\n\n(* -- parse data of any type -- *)\n\n(*\n Some values, such as operations, tickets, or big map ids, are used only\n internally and are not allowed to be forged by users.\n In [parse_data], [allow_forged] should be [false] for:\n - PUSH\n - UNPACK\n - user-provided script parameters\n - storage on origination\n And [true] for:\n - internal calls parameters\n - storage after origination\n*)\n\nlet rec parse_data :\n type a ac.\n unparse_code_rec:Script_ir_unparser.unparse_code_rec ->\n elab_conf:elab_conf ->\n stack_depth:int ->\n context ->\n allow_forged:bool ->\n (a, ac) ty ->\n Script.node ->\n (a * context) tzresult Lwt.t =\n fun ~unparse_code_rec ~elab_conf ~stack_depth ctxt ~allow_forged ty script_data ->\n Gas.consume ctxt Typecheck_costs.parse_data_cycle >>?= fun ctxt ->\n let non_terminal_recursion ctxt ty script_data =\n if Compare.Int.(stack_depth > 10_000) then\n tzfail Typechecking_too_many_recursive_calls\n else\n parse_data\n ~unparse_code_rec\n ~elab_conf\n ~stack_depth:(stack_depth + 1)\n ctxt\n ~allow_forged\n ty\n script_data\n in\n let parse_data_error () =\n let ty = serialize_ty_for_error ty in\n Invalid_constant (location script_data, strip_locations script_data, ty)\n in\n let fail_parse_data () = tzfail (parse_data_error ()) in\n let traced_no_lwt body = record_trace_eval parse_data_error body in\n let traced body = trace_eval parse_data_error body in\n let traced_fail err = Lwt.return @@ traced_no_lwt (error err) in\n let parse_items ctxt expr key_type value_type items item_wrapper =\n List.fold_left_es\n (fun (last_value, map, ctxt) item ->\n match item with\n | Prim (loc, D_Elt, [k; v], annot) ->\n (if elab_conf.legacy then Result.return_unit\n else error_unexpected_annot loc annot)\n >>?= fun () ->\n non_terminal_recursion ctxt key_type k >>=? fun (k, ctxt) ->\n non_terminal_recursion ctxt value_type v >>=? fun (v, ctxt) ->\n Lwt.return\n ( (match last_value with\n | Some value ->\n Gas.consume\n ctxt\n (Michelson_v1_gas.Cost_of.Interpreter.compare\n key_type\n value\n k)\n >>? fun ctxt ->\n let c =\n Script_comparable.compare_comparable key_type value k\n in\n if Compare.Int.(0 <= c) then\n if Compare.Int.(0 = c) then\n error (Duplicate_map_keys (loc, strip_locations expr))\n else\n error (Unordered_map_keys (loc, strip_locations expr))\n else ok ctxt\n | None -> ok ctxt)\n >>? fun ctxt ->\n Gas.consume\n ctxt\n (Michelson_v1_gas.Cost_of.Interpreter.map_update k map)\n >|? fun ctxt ->\n (Some k, Script_map.update k (Some (item_wrapper v)) map, ctxt)\n )\n | Prim (loc, D_Elt, l, _) ->\n tzfail @@ Invalid_arity (loc, D_Elt, 2, List.length l)\n | Prim (loc, name, _, _) ->\n tzfail @@ Invalid_primitive (loc, [D_Elt], name)\n | Int _ | String _ | Bytes _ | Seq _ -> fail_parse_data ())\n (None, Script_map.empty key_type, ctxt)\n items\n |> traced\n >|=? fun (_, items, ctxt) -> (items, ctxt)\n in\n let parse_big_map_items (type t) ctxt expr (key_type : t comparable_ty)\n value_type items item_wrapper =\n List.fold_left_es\n (fun (last_key, {map; size}, ctxt) item ->\n match item with\n | Prim (loc, D_Elt, [k; v], annot) ->\n (if elab_conf.legacy then Result.return_unit\n else error_unexpected_annot loc annot)\n >>?= fun () ->\n non_terminal_recursion ctxt key_type k >>=? fun (k, ctxt) ->\n hash_comparable_data ctxt key_type k >>=? fun (key_hash, ctxt) ->\n non_terminal_recursion ctxt value_type v >>=? fun (v, ctxt) ->\n Lwt.return\n ( (match last_key with\n | Some last_key ->\n Gas.consume\n ctxt\n (Michelson_v1_gas.Cost_of.Interpreter.compare\n key_type\n last_key\n k)\n >>? fun ctxt ->\n let c =\n Script_comparable.compare_comparable key_type last_key k\n in\n if Compare.Int.(0 <= c) then\n if Compare.Int.(0 = c) then\n error (Duplicate_map_keys (loc, strip_locations expr))\n else\n error (Unordered_map_keys (loc, strip_locations expr))\n else ok ctxt\n | None -> ok ctxt)\n >>? fun ctxt ->\n Gas.consume\n ctxt\n (Michelson_v1_gas.Cost_of.Interpreter.big_map_update\n {map; size})\n >>? fun ctxt ->\n if Big_map_overlay.mem key_hash map then\n error (Duplicate_map_keys (loc, strip_locations expr))\n else\n ok\n ( Some k,\n {\n map =\n Big_map_overlay.add key_hash (k, item_wrapper v) map;\n size = size + 1;\n },\n ctxt ) )\n | Prim (loc, D_Elt, l, _) ->\n tzfail @@ Invalid_arity (loc, D_Elt, 2, List.length l)\n | Prim (loc, name, _, _) ->\n tzfail @@ Invalid_primitive (loc, [D_Elt], name)\n | Int _ | String _ | Bytes _ | Seq _ -> fail_parse_data ())\n (None, {map = Big_map_overlay.empty; size = 0}, ctxt)\n items\n |> traced\n >|=? fun (_, map, ctxt) -> (map, ctxt)\n in\n let legacy = elab_conf.legacy in\n match (ty, script_data) with\n | Unit_t, expr ->\n Lwt.return @@ traced_no_lwt\n @@ (parse_unit ctxt ~legacy expr : (a * context) tzresult)\n | Bool_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_bool ctxt ~legacy expr\n | String_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_string ctxt expr\n | Bytes_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_bytes ctxt expr\n | Int_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_int ctxt expr\n | Nat_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_nat ctxt expr\n | Mutez_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_mutez ctxt expr\n | Timestamp_t, expr ->\n Lwt.return @@ traced_no_lwt @@ parse_timestamp ctxt expr\n | Key_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_key ctxt expr\n | Key_hash_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_key_hash ctxt expr\n | Signature_t, expr ->\n Lwt.return @@ traced_no_lwt @@ parse_signature ctxt expr\n | Operation_t, _ ->\n (* operations cannot appear in parameters or storage,\n the protocol should never parse the bytes of an operation *)\n assert false\n | Chain_id_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_chain_id ctxt expr\n | Address_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_address ctxt expr\n | Tx_rollup_l2_address_t, expr ->\n if Constants.tx_rollup_enable ctxt || legacy then\n Lwt.return @@ traced_no_lwt @@ parse_tx_rollup_l2_address ctxt expr\n else tzfail (Deprecated_instruction T_tx_rollup_l2_address)\n | Contract_t (arg_ty, _), expr ->\n traced\n ( parse_address ctxt expr >>?= fun (address, ctxt) ->\n let loc = location expr in\n parse_contract_data\n ~stack_depth:(stack_depth + 1)\n ctxt\n loc\n arg_ty\n address.destination\n ~entrypoint:address.entrypoint\n >|=? fun (ctxt, typed_contract) -> (typed_contract, ctxt) )\n (* Pairs *)\n | Pair_t (tl, tr, _, _), expr ->\n let r_witness = comb_witness1 tr in\n let parse_l ctxt v = non_terminal_recursion ctxt tl v in\n let parse_r ctxt v = non_terminal_recursion ctxt tr v in\n traced @@ parse_pair parse_l parse_r ctxt ~legacy r_witness expr\n (* Unions *)\n | Union_t (tl, tr, _, _), expr ->\n let parse_l ctxt v = non_terminal_recursion ctxt tl v in\n let parse_r ctxt v = non_terminal_recursion ctxt tr v in\n traced @@ parse_union parse_l parse_r ctxt ~legacy expr\n (* Lambdas *)\n | Lambda_t (ta, tr, _ty_name), (Seq (_loc, _) as script_instr) ->\n traced\n @@ parse_kdescr\n ~unparse_code_rec\n Tc_context.data\n ~elab_conf\n ~stack_depth:(stack_depth + 1)\n ctxt\n ta\n tr\n script_instr\n >>=? fun (kdescr, ctxt) ->\n (normalized_lam [@ocaml.tailcall])\n ~unparse_code_rec\n ctxt\n ~stack_depth\n kdescr\n script_instr\n | ( Lambda_t (ta, tr, _ty_name),\n Prim (loc, D_Lambda_rec, [(Seq (_loc, _) as script_instr)], []) ) ->\n traced\n @@ ( lambda_t loc ta tr >>?= fun lambda_rec_ty ->\n parse_lam_rec\n ~unparse_code_rec\n Tc_context.(add_lambda data)\n ~elab_conf\n ~stack_depth:(stack_depth + 1)\n ctxt\n ta\n tr\n lambda_rec_ty\n script_instr )\n | Lambda_t _, expr ->\n traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr))\n (* Options *)\n | Option_t (t, _, _), expr ->\n let parse_v ctxt v = non_terminal_recursion ctxt t v in\n traced @@ parse_option parse_v ctxt ~legacy expr\n (* Lists *)\n | List_t (t, _ty_name), Seq (_loc, items) ->\n traced\n @@ List.fold_right_es\n (fun v (rest, ctxt) ->\n non_terminal_recursion ctxt t v >|=? fun (v, ctxt) ->\n (Script_list.cons v rest, ctxt))\n items\n (Script_list.empty, ctxt)\n | List_t _, expr ->\n traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr))\n (* Tickets *)\n | Ticket_t (t, _ty_name), expr ->\n if allow_forged then\n opened_ticket_type (location expr) t >>?= fun ty ->\n non_terminal_recursion ctxt ty expr\n >>=? fun (({destination; entrypoint = _}, (contents, amount)), ctxt) ->\n match Ticket_amount.of_n amount with\n | Some amount -> (\n match destination with\n | Contract ticketer -> return ({ticketer; contents; amount}, ctxt)\n | Tx_rollup _ | Sc_rollup _ | Zk_rollup _ ->\n tzfail (Unexpected_ticket_owner destination))\n | None -> traced_fail Forbidden_zero_ticket_quantity\n else traced_fail (Unexpected_forged_value (location expr))\n (* Sets *)\n | Set_t (t, _ty_name), (Seq (loc, vs) as expr) ->\n traced\n @@ List.fold_left_es\n (fun (last_value, set, ctxt) v ->\n non_terminal_recursion ctxt t v >>=? fun (v, ctxt) ->\n Lwt.return\n ( (match last_value with\n | Some value ->\n Gas.consume\n ctxt\n (Michelson_v1_gas.Cost_of.Interpreter.compare t value v)\n >>? fun ctxt ->\n let c = Script_comparable.compare_comparable t value v in\n if Compare.Int.(0 <= c) then\n if Compare.Int.(0 = c) then\n error\n (Duplicate_set_values (loc, strip_locations expr))\n else\n error\n (Unordered_set_values (loc, strip_locations expr))\n else ok ctxt\n | None -> ok ctxt)\n >>? fun ctxt ->\n Gas.consume\n ctxt\n (Michelson_v1_gas.Cost_of.Interpreter.set_update v set)\n >|? fun ctxt -> (Some v, Script_set.update v true set, ctxt) ))\n (None, Script_set.empty t, ctxt)\n vs\n >|=? fun (_, set, ctxt) -> (set, ctxt)\n | Set_t _, expr ->\n traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr))\n (* Maps *)\n | Map_t (tk, tv, _ty_name), (Seq (_, vs) as expr) ->\n parse_items ctxt expr tk tv vs (fun x -> x)\n | Map_t _, expr ->\n traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr))\n | Big_map_t (tk, tv, _ty_name), expr ->\n (match expr with\n | Int (loc, id) ->\n return (Some (id, loc), {map = Big_map_overlay.empty; size = 0}, ctxt)\n | Seq (_, vs) ->\n parse_big_map_items ctxt expr tk tv vs (fun x -> Some x)\n >|=? fun (diff, ctxt) -> (None, diff, ctxt)\n | Prim (loc, D_Pair, [Int (loc_id, id); Seq (_, vs)], annot) ->\n error_unexpected_annot loc annot >>?= fun () ->\n option_t loc tv >>?= fun tv_opt ->\n parse_big_map_items ctxt expr tk tv_opt vs (fun x -> x)\n >|=? fun (diff, ctxt) -> (Some (id, loc_id), diff, ctxt)\n | Prim (_, D_Pair, [Int _; expr], _) ->\n traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr))\n | Prim (_, D_Pair, [expr; _], _) ->\n traced_fail (Invalid_kind (location expr, [Int_kind], kind expr))\n | Prim (loc, D_Pair, l, _) ->\n traced_fail @@ Invalid_arity (loc, D_Pair, 2, List.length l)\n | _ ->\n traced_fail\n (unexpected expr [Seq_kind; Int_kind] Constant_namespace [D_Pair]))\n >>=? fun (id_opt, diff, ctxt) ->\n (match id_opt with\n | None -> return @@ (None, ctxt)\n | Some (id, loc) ->\n if allow_forged then\n let id = Big_map.Id.parse_z id in\n Big_map.exists ctxt id >>=? function\n | _, None -> traced_fail (Invalid_big_map (loc, id))\n | ctxt, Some (btk, btv) ->\n Lwt.return\n ( parse_comparable_ty\n ~stack_depth:(stack_depth + 1)\n ctxt\n (Micheline.root btk)\n >>? fun (Ex_comparable_ty btk, ctxt) ->\n parse_big_map_value_ty\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy\n (Micheline.root btv)\n >>? fun (Ex_ty btv, ctxt) ->\n (Gas_monad.run ctxt\n @@\n let open Gas_monad.Syntax in\n let error_details = Informative loc in\n let* Eq = ty_eq ~error_details tk btk in\n ty_eq ~error_details tv btv)\n >>? fun (eq, ctxt) ->\n eq >|? fun Eq -> (Some id, ctxt) )\n else traced_fail (Unexpected_forged_value loc))\n >|=? fun (id, ctxt) ->\n (Big_map {id; diff; key_type = tk; value_type = tv}, ctxt)\n | Never_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_never expr\n (* Bls12_381 types *)\n | Bls12_381_g1_t, Bytes (_, bs) -> (\n Gas.consume ctxt Typecheck_costs.bls12_381_g1 >>?= fun ctxt ->\n match Script_bls.G1.of_bytes_opt bs with\n | Some pt -> return (pt, ctxt)\n | None -> fail_parse_data ())\n | Bls12_381_g1_t, expr ->\n traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))\n | Bls12_381_g2_t, Bytes (_, bs) -> (\n Gas.consume ctxt Typecheck_costs.bls12_381_g2 >>?= fun ctxt ->\n match Script_bls.G2.of_bytes_opt bs with\n | Some pt -> return (pt, ctxt)\n | None -> fail_parse_data ())\n | Bls12_381_g2_t, expr ->\n traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))\n | Bls12_381_fr_t, Bytes (_, bs) -> (\n Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt ->\n match Script_bls.Fr.of_bytes_opt bs with\n | Some pt -> return (pt, ctxt)\n | None -> fail_parse_data ())\n | Bls12_381_fr_t, Int (_, v) ->\n Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt ->\n return (Script_bls.Fr.of_z v, ctxt)\n | Bls12_381_fr_t, expr ->\n traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))\n (*\n /!\\ When adding new lazy storage kinds, you may want to guard the parsing\n of identifiers with [allow_forged].\n *)\n (* Sapling *)\n | Sapling_transaction_t memo_size, Bytes (_, bytes) -> (\n match\n Data_encoding.Binary.of_bytes_opt Sapling.transaction_encoding bytes\n with\n | Some transaction -> (\n match Sapling.transaction_get_memo_size transaction with\n | None -> return (transaction, ctxt)\n | Some transac_memo_size ->\n Lwt.return\n ( memo_size_eq\n ~error_details:(Informative ())\n memo_size\n transac_memo_size\n >|? fun () -> (transaction, ctxt) ))\n | None -> fail_parse_data ())\n | Sapling_transaction_t _, expr ->\n traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))\n | Sapling_transaction_deprecated_t memo_size, Bytes (_, bytes) -> (\n match\n Data_encoding.Binary.of_bytes_opt\n Sapling.Legacy.transaction_encoding\n bytes\n with\n | Some transaction -> (\n match Sapling.Legacy.transaction_get_memo_size transaction with\n | None -> return (transaction, ctxt)\n | Some transac_memo_size ->\n Lwt.return\n ( memo_size_eq\n ~error_details:(Informative ())\n memo_size\n transac_memo_size\n >|? fun () -> (transaction, ctxt) ))\n | None -> fail_parse_data ())\n | Sapling_transaction_deprecated_t _, expr ->\n traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))\n | Sapling_state_t memo_size, Int (loc, id) ->\n if allow_forged then\n let id = Sapling.Id.parse_z id in\n Sapling.state_from_id ctxt id >>=? fun (state, ctxt) ->\n Lwt.return\n ( traced_no_lwt\n @@ memo_size_eq\n ~error_details:(Informative ())\n memo_size\n state.Sapling.memo_size\n >|? fun () -> (state, ctxt) )\n else traced_fail (Unexpected_forged_value loc)\n | Sapling_state_t memo_size, Seq (_, []) ->\n return (Sapling.empty_state ~memo_size (), ctxt)\n | Sapling_state_t _, expr ->\n (* Do not allow to input diffs as they are untrusted and may not be the\n result of a verify_update. *)\n traced_fail\n (Invalid_kind (location expr, [Int_kind; Seq_kind], kind expr))\n (* Time lock*)\n | Chest_key_t, Bytes (_, bytes) -> (\n Gas.consume ctxt Typecheck_costs.chest_key >>?= fun ctxt ->\n match\n Data_encoding.Binary.of_bytes_opt\n Script_timelock.chest_key_encoding\n bytes\n with\n | Some chest_key -> return (chest_key, ctxt)\n | None -> fail_parse_data ())\n | Chest_key_t, expr ->\n traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))\n | Chest_t, Bytes (_, bytes) -> (\n Gas.consume ctxt (Typecheck_costs.chest ~bytes:(Bytes.length bytes))\n >>?= fun ctxt ->\n match\n Data_encoding.Binary.of_bytes_opt Script_timelock.chest_encoding bytes\n with\n | Some chest -> return (chest, ctxt)\n | None -> fail_parse_data ())\n | Chest_t, expr ->\n traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))\n\nand parse_view :\n type storage storagec.\n unparse_code_rec:Script_ir_unparser.unparse_code_rec ->\n elab_conf:elab_conf ->\n context ->\n (storage, storagec) ty ->\n view ->\n (storage typed_view * context) tzresult Lwt.t =\n fun ~unparse_code_rec\n ~elab_conf\n ctxt\n storage_type\n {input_ty; output_ty; view_code} ->\n let legacy = elab_conf.legacy in\n let input_ty_loc = location input_ty in\n record_trace_eval\n (fun () ->\n Ill_formed_type\n (Some \"arg of view\", strip_locations input_ty, input_ty_loc))\n (parse_view_input_ty ctxt ~stack_depth:0 ~legacy input_ty)\n >>?= fun (Ex_ty input_ty, ctxt) ->\n let output_ty_loc = location output_ty in\n record_trace_eval\n (fun () ->\n Ill_formed_type\n (Some \"return of view\", strip_locations output_ty, output_ty_loc))\n (parse_view_output_ty ctxt ~stack_depth:0 ~legacy output_ty)\n >>?= fun (Ex_ty output_ty, ctxt) ->\n pair_t input_ty_loc input_ty storage_type >>?= fun (Ty_ex_c pair_ty) ->\n parse_instr\n ~unparse_code_rec\n ~elab_conf\n ~stack_depth:0\n Tc_context.view\n ctxt\n view_code\n (Item_t (pair_ty, Bot_t))\n >>=? fun (judgement, ctxt) ->\n Lwt.return\n @@\n match judgement with\n | Failed {descr} ->\n let {kinstr; _} = close_descr (descr (Item_t (output_ty, Bot_t))) in\n ok\n ( Typed_view\n {input_ty; output_ty; kinstr; original_code_expr = view_code},\n ctxt )\n | Typed ({loc; aft; _} as descr) -> (\n let ill_type_view stack_ty loc =\n let actual = serialize_stack_for_error ctxt stack_ty in\n let expected_stack = Item_t (output_ty, Bot_t) in\n let expected = serialize_stack_for_error ctxt expected_stack in\n Ill_typed_view {loc; actual; expected}\n in\n match aft with\n | Item_t (ty, Bot_t) ->\n let error_details = Informative loc in\n Gas_monad.run ctxt\n @@ Gas_monad.record_trace_eval ~error_details (fun loc ->\n ill_type_view aft loc)\n @@ ty_eq ~error_details ty output_ty\n >>? fun (eq, ctxt) ->\n eq >|? fun Eq ->\n let {kinstr; _} = close_descr descr in\n ( Typed_view\n {input_ty; output_ty; kinstr; original_code_expr = view_code},\n ctxt )\n | _ -> error (ill_type_view aft loc))\n\nand parse_views :\n type storage storagec.\n unparse_code_rec:Script_ir_unparser.unparse_code_rec ->\n elab_conf:elab_conf ->\n context ->\n (storage, storagec) ty ->\n view_map ->\n (storage typed_view_map * context) tzresult Lwt.t =\n fun ~unparse_code_rec ~elab_conf ctxt storage_type views ->\n let aux ctxt name cur_view =\n Gas.consume\n ctxt\n (Michelson_v1_gas.Cost_of.Interpreter.view_update name views)\n >>?= fun ctxt ->\n parse_view ~unparse_code_rec ~elab_conf ctxt storage_type cur_view\n in\n Script_map.map_es_in_context aux ctxt views\n\nand parse_kdescr :\n type arg argc ret retc.\n unparse_code_rec:Script_ir_unparser.unparse_code_rec ->\n elab_conf:elab_conf ->\n stack_depth:int ->\n tc_context ->\n context ->\n (arg, argc) ty ->\n (ret, retc) ty ->\n Script.node ->\n ((arg, end_of_stack, ret, end_of_stack) kdescr * context) tzresult Lwt.t =\n fun ~unparse_code_rec\n ~elab_conf\n ~stack_depth\n tc_context\n ctxt\n arg\n ret\n script_instr ->\n parse_instr\n ~unparse_code_rec\n ~elab_conf\n tc_context\n ctxt\n ~stack_depth:(stack_depth + 1)\n script_instr\n (Item_t (arg, Bot_t))\n >>=? function\n | Typed ({loc; aft = Item_t (ty, Bot_t) as stack_ty; _} as descr), ctxt ->\n Lwt.return\n (let error_details = Informative loc in\n Gas_monad.run ctxt\n @@ Gas_monad.record_trace_eval ~error_details (fun loc ->\n let ret = serialize_ty_for_error ret in\n let stack_ty = serialize_stack_for_error ctxt stack_ty in\n Bad_return (loc, stack_ty, ret))\n @@ ty_eq ~error_details ty ret\n >>? fun (eq, ctxt) ->\n eq >|? fun Eq ->\n ( (close_descr descr : (arg, end_of_stack, ret, end_of_stack) kdescr),\n ctxt ))\n | Typed {loc; aft = stack_ty; _}, ctxt ->\n let ret = serialize_ty_for_error ret in\n let stack_ty = serialize_stack_for_error ctxt stack_ty in\n tzfail @@ Bad_return (loc, stack_ty, ret)\n | Failed {descr}, ctxt ->\n return\n ( (close_descr (descr (Item_t (ret, Bot_t)))\n : (arg, end_of_stack, ret, end_of_stack) kdescr),\n ctxt )\n\nand parse_lam_rec :\n type arg argc ret retc.\n unparse_code_rec:Script_ir_unparser.unparse_code_rec ->\n elab_conf:elab_conf ->\n stack_depth:int ->\n tc_context ->\n context ->\n (arg, argc) ty ->\n (ret, retc) ty ->\n ((arg, ret) lambda, _) ty ->\n Script.node ->\n ((arg, ret) lambda * context) tzresult Lwt.t =\n fun ~unparse_code_rec\n ~elab_conf\n ~stack_depth\n tc_context\n ctxt\n arg\n ret\n lambda_rec_ty\n script_instr ->\n parse_instr\n ~unparse_code_rec\n ~elab_conf\n tc_context\n ctxt\n ~stack_depth:(stack_depth + 1)\n script_instr\n (Item_t (arg, Item_t (lambda_rec_ty, Bot_t)))\n >>=? function\n | Typed ({loc; aft = Item_t (ty, Bot_t) as stack_ty; _} as descr), ctxt ->\n Lwt.return\n (let error_details = Informative loc in\n Gas_monad.run ctxt\n @@ Gas_monad.record_trace_eval ~error_details (fun loc ->\n let ret = serialize_ty_for_error ret in\n let stack_ty = serialize_stack_for_error ctxt stack_ty in\n Bad_return (loc, stack_ty, ret))\n @@ ty_eq ~error_details ty ret\n >>? fun (eq, ctxt) ->\n eq >|? fun Eq ->\n ( (close_descr descr\n : (arg, (arg, ret) lambda * end_of_stack, ret, end_of_stack) kdescr),\n ctxt ))\n >>=? fun (closed_descr, ctxt) ->\n (normalized_lam_rec [@ocaml.tailcall])\n ~unparse_code_rec\n ~stack_depth\n ctxt\n closed_descr\n script_instr\n | Typed {loc; aft = stack_ty; _}, ctxt ->\n let ret = serialize_ty_for_error ret in\n let stack_ty = serialize_stack_for_error ctxt stack_ty in\n tzfail @@ Bad_return (loc, stack_ty, ret)\n | Failed {descr}, ctxt ->\n (normalized_lam_rec [@ocaml.tailcall])\n ~unparse_code_rec\n ~stack_depth\n ctxt\n (close_descr (descr (Item_t (ret, Bot_t))))\n script_instr\n\nand parse_instr :\n type a s.\n unparse_code_rec:Script_ir_unparser.unparse_code_rec ->\n elab_conf:elab_conf ->\n stack_depth:int ->\n tc_context ->\n context ->\n Script.node ->\n (a, s) stack_ty ->\n ((a, s) judgement * context) tzresult Lwt.t =\n fun ~unparse_code_rec\n ~elab_conf\n ~stack_depth\n tc_context\n ctxt\n script_instr\n stack_ty ->\n let for_logging_only x =\n if elab_conf.keep_extra_types_for_interpreter_logging then Some x else None\n in\n let check_item_ty (type a ac b bc) ctxt (exp : (a, ac) ty) (got : (b, bc) ty)\n loc name n m : ((a, b) eq * context) tzresult =\n record_trace_eval (fun () ->\n let stack_ty = serialize_stack_for_error ctxt stack_ty in\n Bad_stack (loc, name, m, stack_ty))\n @@ record_trace\n (Bad_stack_item n)\n ( Gas_monad.run ctxt @@ ty_eq ~error_details:(Informative loc) exp got\n >>? fun (eq, ctxt) ->\n eq >|? fun Eq -> ((Eq : (a, b) eq), ctxt) )\n in\n let log_stack loc stack_ty aft =\n match (elab_conf.type_logger, script_instr) with\n | None, _ | Some _, (Int _ | String _ | Bytes _) -> ()\n | Some log, (Prim _ | Seq _) ->\n (* Unparsing for logging is not carbonated as this\n is used only by the client and not the protocol *)\n let stack_ty_before = unparse_stack_uncarbonated stack_ty in\n let stack_ty_after = unparse_stack_uncarbonated aft in\n log loc ~stack_ty_before ~stack_ty_after\n in\n let typed_no_lwt ctxt loc instr aft =\n log_stack loc stack_ty aft ;\n let j = Typed {loc; instr; bef = stack_ty; aft} in\n Ok (j, ctxt)\n in\n let typed ctxt loc instr aft =\n Lwt.return @@ typed_no_lwt ctxt loc instr aft\n in\n Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt ->\n let non_terminal_recursion tc_context ctxt script_instr stack_ty =\n if Compare.Int.(stack_depth > 10000) then\n tzfail Typechecking_too_many_recursive_calls\n else\n parse_instr\n ~unparse_code_rec\n ~elab_conf\n tc_context\n ctxt\n ~stack_depth:(stack_depth + 1)\n script_instr\n stack_ty\n in\n let bad_stack_error ctxt loc prim relevant_stack_portion =\n let whole_stack = serialize_stack_for_error ctxt stack_ty in\n error (Bad_stack (loc, prim, relevant_stack_portion, whole_stack))\n in\n let legacy = elab_conf.legacy in\n match (script_instr, stack_ty) with\n (* stack ops *)\n | Prim (loc, I_DROP, [], annot), Item_t (_, rest) ->\n (error_unexpected_annot loc annot >>?= fun () ->\n typed ctxt loc {apply = (fun k -> IDrop (loc, k))} rest\n : ((a, s) judgement * context) tzresult Lwt.t)\n | Prim (loc, I_DROP, [n], result_annot), whole_stack ->\n parse_uint10 n >>?= fun whole_n ->\n Gas.consume ctxt (Typecheck_costs.proof_argument whole_n) >>?= fun ctxt ->\n let rec make_proof_argument :\n type a s.\n int -> (a, s) stack_ty -> (a, s) dropn_proof_argument tzresult =\n fun n stk ->\n match (Compare.Int.(n = 0), stk) with\n | true, rest -> ok @@ Dropn_proof_argument (KRest, rest)\n | false, Item_t (a, rest) ->\n make_proof_argument (n - 1) rest\n >|? fun (Dropn_proof_argument (n', stack_after_drops)) ->\n Dropn_proof_argument (KPrefix (loc, a, n'), stack_after_drops)\n | _, _ ->\n let whole_stack = serialize_stack_for_error ctxt whole_stack in\n error (Bad_stack (loc, I_DROP, whole_n, whole_stack))\n in\n error_unexpected_annot loc result_annot >>?= fun () ->\n make_proof_argument whole_n whole_stack\n >>?= fun (Dropn_proof_argument (n', stack_after_drops)) ->\n let kdropn k = IDropn (loc, whole_n, n', k) in\n typed ctxt loc {apply = kdropn} stack_after_drops\n | Prim (loc, I_DROP, (_ :: _ :: _ as l), _), _ ->\n (* Technically, the arities 0 and 1 are allowed but the error only mentions 1.\n However, DROP is equivalent to DROP 1 so hinting at an arity of 1 makes sense. *)\n tzfail (Invalid_arity (loc, I_DROP, 1, List.length l))\n | Prim (loc, I_DUP, [], annot), (Item_t (v, _) as stack) ->\n check_var_annot loc annot >>?= fun () ->\n record_trace_eval\n (fun () ->\n let t = serialize_ty_for_error v in\n Non_dupable_type (loc, t))\n (check_dupable_ty ctxt loc v)\n >>?= fun ctxt ->\n let dup = {apply = (fun k -> IDup (loc, k))} in\n typed ctxt loc dup (Item_t (v, stack))\n | Prim (loc, I_DUP, [n], v_annot), (Item_t _ as stack_ty) ->\n check_var_annot loc v_annot >>?= fun () ->\n let rec make_proof_argument :\n type a b s.\n int -> (a, b * s) stack_ty -> (a, b, s) dup_n_proof_argument tzresult\n =\n fun n (stack_ty : (a, b * s) stack_ty) ->\n match (n, stack_ty) with\n | 1, Item_t (hd_ty, _) -> ok @@ Dup_n_proof_argument (Dup_n_zero, hd_ty)\n | n, Item_t (_, (Item_t (_, _) as tl_ty)) ->\n make_proof_argument (n - 1) tl_ty\n >|? fun (Dup_n_proof_argument (dup_n_witness, b_ty)) ->\n Dup_n_proof_argument (Dup_n_succ dup_n_witness, b_ty)\n | _ -> bad_stack_error ctxt loc I_DUP 1\n in\n parse_uint10 n >>?= fun n ->\n Gas.consume ctxt (Typecheck_costs.proof_argument n) >>?= fun ctxt ->\n error_unless (Compare.Int.( > ) n 0) (Dup_n_bad_argument loc)\n >>?= fun () ->\n record_trace (Dup_n_bad_stack loc) (make_proof_argument n stack_ty)\n >>?= fun (Dup_n_proof_argument (witness, after_ty)) ->\n record_trace_eval\n (fun () ->\n let t = serialize_ty_for_error after_ty in\n Non_dupable_type (loc, t))\n (check_dupable_ty ctxt loc after_ty)\n >>?= fun ctxt ->\n let dupn = {apply = (fun k -> IDup_n (loc, n, witness, k))} in\n typed ctxt loc dupn (Item_t (after_ty, stack_ty))\n | Prim (loc, I_DIG, [n], result_annot), stack ->\n let rec make_proof_argument :\n type a s. int -> (a, s) stack_ty -> (a, s) dig_proof_argument tzresult\n =\n fun n stk ->\n match (Compare.Int.(n = 0), stk) with\n | true, Item_t (v, rest) -> ok @@ Dig_proof_argument (KRest, v, rest)\n | false, Item_t (v, rest) ->\n make_proof_argument (n - 1) rest\n >|? fun (Dig_proof_argument (n', x, aft')) ->\n Dig_proof_argument (KPrefix (loc, v, n'), x, Item_t (v, aft'))\n | _, _ ->\n let whole_stack = serialize_stack_for_error ctxt stack in\n error (Bad_stack (loc, I_DIG, 3, whole_stack))\n in\n parse_uint10 n >>?= fun n ->\n Gas.consume ctxt (Typecheck_costs.proof_argument n) >>?= fun ctxt ->\n error_unexpected_annot loc result_annot >>?= fun () ->\n make_proof_argument n stack >>?= fun (Dig_proof_argument (n', x, aft)) ->\n let dig = {apply = (fun k -> IDig (loc, n, n', k))} in\n typed ctxt loc dig (Item_t (x, aft))\n | Prim (loc, I_DIG, (([] | _ :: _ :: _) as l), _), _ ->\n tzfail (Invalid_arity (loc, I_DIG, 1, List.length l))\n | Prim (loc, I_DUG, [n], result_annot), Item_t (x, whole_stack) -> (\n parse_uint10 n >>?= fun whole_n ->\n Gas.consume ctxt (Typecheck_costs.proof_argument whole_n) >>?= fun ctxt ->\n error_unexpected_annot loc result_annot >>?= fun () ->\n match make_dug_proof_argument loc whole_n x whole_stack with\n | None ->\n let whole_stack = serialize_stack_for_error ctxt whole_stack in\n tzfail (Bad_stack (loc, I_DUG, whole_n, whole_stack))\n | Some (Dug_proof_argument (n', aft)) ->\n let dug = {apply = (fun k -> IDug (loc, whole_n, n', k))} in\n typed ctxt loc dug aft)\n | Prim (loc, I_DUG, [_], result_annot), stack ->\n Lwt.return\n ( error_unexpected_annot loc result_annot >>? fun () ->\n let stack = serialize_stack_for_error ctxt stack in\n error (Bad_stack (loc, I_DUG, 1, stack)) )\n | Prim (loc, I_DUG, (([] | _ :: _ :: _) as l), _), _ ->\n tzfail (Invalid_arity (loc, I_DUG, 1, List.length l))\n | Prim (loc, I_SWAP, [], annot), Item_t (v, Item_t (w, rest)) ->\n error_unexpected_annot loc annot >>?= fun () ->\n let swap = {apply = (fun k -> ISwap (loc, k))} in\n let stack_ty = Item_t (w, Item_t (v, rest)) in\n typed ctxt loc swap stack_ty\n | Prim (loc, I_PUSH, [t; d], annot), stack ->\n check_var_annot loc annot >>?= fun () ->\n parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t\n >>?= fun (Ex_ty t, ctxt) ->\n parse_data\n ~unparse_code_rec\n ~elab_conf\n ~stack_depth:(stack_depth + 1)\n ctxt\n ~allow_forged:false\n t\n d\n >>=? fun (v, ctxt) ->\n let const = {apply = (fun k -> IConst (loc, t, v, k))} in\n typed ctxt loc const (Item_t (t, stack))\n | Prim (loc, I_UNIT, [], annot), stack ->\n check_var_type_annot loc annot >>?= fun () ->\n let const = {apply = (fun k -> IConst (loc, unit_t, (), k))} in\n typed ctxt loc const (Item_t (unit_t, stack))\n (* options *)\n | Prim (loc, I_SOME, [], annot), Item_t (t, rest) ->\n check_var_type_annot loc annot >>?= fun () ->\n let cons_some = {apply = (fun k -> ICons_some (loc, k))} in\n option_t loc t >>?= fun ty -> typed ctxt loc cons_some (Item_t (ty, rest))\n | Prim (loc, I_NONE, [t], annot), stack ->\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t\n >>?= fun (Ex_ty t, ctxt) ->\n check_var_type_annot loc annot >>?= fun () ->\n let cons_none = {apply = (fun k -> ICons_none (loc, t, k))} in\n option_t loc t >>?= fun ty ->\n let stack_ty = Item_t (ty, stack) in\n typed ctxt loc cons_none stack_ty\n | Prim (loc, I_MAP, [body], annot), Item_t (Option_t (t, _, _), rest) -> (\n check_kind [Seq_kind] body >>?= fun () ->\n check_var_type_annot loc annot >>?= fun () ->\n non_terminal_recursion tc_context ctxt body (Item_t (t, rest))\n >>=? fun (judgement, ctxt) ->\n Lwt.return\n @@\n match judgement with\n | Typed ({loc; aft = Item_t (ret, aft_rest); _} as kibody) ->\n let invalid_map_body () =\n let aft = serialize_stack_for_error ctxt kibody.aft in\n Invalid_map_body (loc, aft)\n in\n record_trace_eval\n invalid_map_body\n ( stack_eq loc ctxt 1 aft_rest rest >>? fun (Eq, ctxt) ->\n option_t loc ret >>? fun opt_ty ->\n let final_stack = Item_t (opt_ty, rest) in\n let body = kibody.instr.apply (IHalt loc) in\n let apply k = IOpt_map {loc; body; k} in\n typed_no_lwt ctxt loc {apply} final_stack )\n | Typed {aft = Bot_t; _} ->\n let aft = serialize_stack_for_error ctxt Bot_t in\n error (Invalid_map_body (loc, aft))\n | Failed _ -> error (Invalid_map_block_fail loc))\n | ( Prim (loc, I_IF_NONE, [bt; bf], annot),\n (Item_t (Option_t (t, _, _), rest) as bef) ) ->\n check_kind [Seq_kind] bt >>?= fun () ->\n check_kind [Seq_kind] bf >>?= fun () ->\n error_unexpected_annot loc annot >>?= fun () ->\n non_terminal_recursion tc_context ctxt bt rest >>=? fun (btr, ctxt) ->\n let stack_ty = Item_t (t, rest) in\n non_terminal_recursion tc_context ctxt bf stack_ty >>=? fun (bfr, ctxt) ->\n let branch ibt ibf =\n let ifnone =\n {\n apply =\n (fun k ->\n let hloc = kinstr_location k in\n let branch_if_none = ibt.instr.apply (IHalt hloc)\n and branch_if_some = ibf.instr.apply (IHalt hloc) in\n IIf_none {loc; branch_if_none; branch_if_some; k});\n }\n in\n {loc; instr = ifnone; bef; aft = ibt.aft}\n in\n Lwt.return @@ merge_branches ctxt loc btr bfr {branch}\n (* pairs *)\n | Prim (loc, I_PAIR, [], annot), Item_t (a, Item_t (b, rest)) ->\n check_constr_annot loc annot >>?= fun () ->\n pair_t loc a b >>?= fun (Ty_ex_c ty) ->\n let stack_ty = Item_t (ty, rest) in\n let cons_pair = {apply = (fun k -> ICons_pair (loc, k))} in\n typed ctxt loc cons_pair stack_ty\n | Prim (loc, I_PAIR, [n], annot), (Item_t _ as stack_ty) ->\n check_var_annot loc annot >>?= fun () ->\n let rec make_proof_argument :\n type a b s.\n int -> (a, b * s) stack_ty -> (a, b, s) comb_proof_argument tzresult =\n fun n stack_ty ->\n match (n, stack_ty) with\n | 1, Item_t _ -> ok (Comb_proof_argument (Comb_one, stack_ty))\n | n, Item_t (a_ty, (Item_t _ as tl_ty)) ->\n make_proof_argument (n - 1) tl_ty\n >>? fun (Comb_proof_argument (comb_witness, Item_t (b_ty, tl_ty')))\n ->\n pair_t loc a_ty b_ty >|? fun (Ty_ex_c pair_t) ->\n Comb_proof_argument (Comb_succ comb_witness, Item_t (pair_t, tl_ty'))\n | _ -> bad_stack_error ctxt loc I_PAIR 1\n in\n parse_uint10 n >>?= fun n ->\n Gas.consume ctxt (Typecheck_costs.proof_argument n) >>?= fun ctxt ->\n error_unless (Compare.Int.( > ) n 1) (Pair_bad_argument loc)\n >>?= fun () ->\n make_proof_argument n stack_ty\n >>?= fun (Comb_proof_argument (witness, after_ty)) ->\n let comb = {apply = (fun k -> IComb (loc, n, witness, k))} in\n typed ctxt loc comb after_ty\n | Prim (loc, I_UNPAIR, [n], annot), (Item_t _ as stack_ty) ->\n error_unexpected_annot loc annot >>?= fun () ->\n let rec make_proof_argument :\n type a b s.\n int -> (a, b * s) stack_ty -> (a, b, s) uncomb_proof_argument tzresult\n =\n fun n stack_ty ->\n match (n, stack_ty) with\n | 1, (Item_t _ as stack) ->\n ok @@ Uncomb_proof_argument (Uncomb_one, stack)\n | n, Item_t (Pair_t (a_ty, b_ty, _, _), tl_ty) ->\n make_proof_argument (n - 1) (Item_t (b_ty, tl_ty))\n >|? fun (Uncomb_proof_argument (uncomb_witness, after_ty)) ->\n Uncomb_proof_argument\n (Uncomb_succ uncomb_witness, Item_t (a_ty, after_ty))\n | _ -> bad_stack_error ctxt loc I_UNPAIR 1\n in\n parse_uint10 n >>?= fun n ->\n Gas.consume ctxt (Typecheck_costs.proof_argument n) >>?= fun ctxt ->\n error_unless (Compare.Int.( > ) n 1) (Unpair_bad_argument loc)\n >>?= fun () ->\n make_proof_argument n stack_ty\n >>?= fun (Uncomb_proof_argument (witness, after_ty)) ->\n let uncomb = {apply = (fun k -> IUncomb (loc, n, witness, k))} in\n typed ctxt loc uncomb after_ty\n | Prim (loc, I_GET, [n], annot), Item_t (comb_ty, rest_ty) -> (\n check_var_annot loc annot >>?= fun () ->\n parse_uint11 n >>?= fun n ->\n Gas.consume ctxt (Typecheck_costs.proof_argument n) >>?= fun ctxt ->\n match make_comb_get_proof_argument n comb_ty with\n | None ->\n let whole_stack = serialize_stack_for_error ctxt stack_ty in\n tzfail (Bad_stack (loc, I_GET, 1, whole_stack))\n | Some (Comb_get_proof_argument (witness, ty')) ->\n let after_stack_ty = Item_t (ty', rest_ty) in\n let comb_get = {apply = (fun k -> IComb_get (loc, n, witness, k))} in\n typed ctxt loc comb_get after_stack_ty)\n | ( Prim (loc, I_UPDATE, [n], annot),\n Item_t (value_ty, Item_t (comb_ty, rest_ty)) ) ->\n check_var_annot loc annot >>?= fun () ->\n parse_uint11 n >>?= fun n ->\n Gas.consume ctxt (Typecheck_costs.proof_argument n) >>?= fun ctxt ->\n make_comb_set_proof_argument ctxt stack_ty loc n value_ty comb_ty\n >>?= fun (Comb_set_proof_argument (witness, after_ty)) ->\n let after_stack_ty = Item_t (after_ty, rest_ty) in\n let comb_set = {apply = (fun k -> IComb_set (loc, n, witness, k))} in\n typed ctxt loc comb_set after_stack_ty\n | Prim (loc, I_UNPAIR, [], annot), Item_t (Pair_t (a, b, _, _), rest) ->\n check_unpair_annot loc annot >>?= fun () ->\n let unpair = {apply = (fun k -> IUnpair (loc, k))} in\n typed ctxt loc unpair (Item_t (a, Item_t (b, rest)))\n | Prim (loc, I_CAR, [], annot), Item_t (Pair_t (a, _, _, _), rest) ->\n check_destr_annot loc annot >>?= fun () ->\n let car = {apply = (fun k -> ICar (loc, k))} in\n typed ctxt loc car (Item_t (a, rest))\n | Prim (loc, I_CDR, [], annot), Item_t (Pair_t (_, b, _, _), rest) ->\n check_destr_annot loc annot >>?= fun () ->\n let cdr = {apply = (fun k -> ICdr (loc, k))} in\n typed ctxt loc cdr (Item_t (b, rest))\n (* unions *)\n | Prim (loc, I_LEFT, [tr], annot), Item_t (tl, rest) ->\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tr\n >>?= fun (Ex_ty tr, ctxt) ->\n check_constr_annot loc annot >>?= fun () ->\n let cons_left = {apply = (fun k -> ICons_left (loc, tr, k))} in\n union_t loc tl tr >>?= fun (Ty_ex_c ty) ->\n let stack_ty = Item_t (ty, rest) in\n typed ctxt loc cons_left stack_ty\n | Prim (loc, I_RIGHT, [tl], annot), Item_t (tr, rest) ->\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tl\n >>?= fun (Ex_ty tl, ctxt) ->\n check_constr_annot loc annot >>?= fun () ->\n let cons_right = {apply = (fun k -> ICons_right (loc, tl, k))} in\n union_t loc tl tr >>?= fun (Ty_ex_c ty) ->\n let stack_ty = Item_t (ty, rest) in\n typed ctxt loc cons_right stack_ty\n | ( Prim (loc, I_IF_LEFT, [bt; bf], annot),\n (Item_t (Union_t (tl, tr, _, _), rest) as bef) ) ->\n check_kind [Seq_kind] bt >>?= fun () ->\n check_kind [Seq_kind] bf >>?= fun () ->\n error_unexpected_annot loc annot >>?= fun () ->\n non_terminal_recursion tc_context ctxt bt (Item_t (tl, rest))\n >>=? fun (btr, ctxt) ->\n non_terminal_recursion tc_context ctxt bf (Item_t (tr, rest))\n >>=? fun (bfr, ctxt) ->\n let branch ibt ibf =\n let instr =\n {\n apply =\n (fun k ->\n let hloc = kinstr_location k in\n let branch_if_left = ibt.instr.apply (IHalt hloc)\n and branch_if_right = ibf.instr.apply (IHalt hloc) in\n IIf_left {loc; branch_if_left; branch_if_right; k});\n }\n in\n {loc; instr; bef; aft = ibt.aft}\n in\n Lwt.return @@ merge_branches ctxt loc btr bfr {branch}\n (* lists *)\n | Prim (loc, I_NIL, [t], annot), stack ->\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t\n >>?= fun (Ex_ty t, ctxt) ->\n check_var_type_annot loc annot >>?= fun () ->\n let nil = {apply = (fun k -> INil (loc, t, k))} in\n list_t loc t >>?= fun ty -> typed ctxt loc nil (Item_t (ty, stack))\n | ( Prim (loc, I_CONS, [], annot),\n Item_t (tv, (Item_t (List_t (t, _), _) as stack)) ) ->\n check_item_ty ctxt tv t loc I_CONS 1 2 >>?= fun (Eq, ctxt) ->\n check_var_annot loc annot >>?= fun () ->\n let cons_list = {apply = (fun k -> ICons_list (loc, k))} in\n (typed ctxt loc cons_list stack\n : ((a, s) judgement * context) tzresult Lwt.t)\n | ( Prim (loc, I_IF_CONS, [bt; bf], annot),\n (Item_t (List_t (t, _), rest) as bef) ) ->\n check_kind [Seq_kind] bt >>?= fun () ->\n check_kind [Seq_kind] bf >>?= fun () ->\n error_unexpected_annot loc annot >>?= fun () ->\n non_terminal_recursion tc_context ctxt bt (Item_t (t, bef))\n >>=? fun (btr, ctxt) ->\n non_terminal_recursion tc_context ctxt bf rest >>=? fun (bfr, ctxt) ->\n let branch ibt ibf =\n let instr =\n {\n apply =\n (fun k ->\n let hloc = kinstr_location k in\n let branch_if_cons = ibt.instr.apply (IHalt hloc)\n and branch_if_nil = ibf.instr.apply (IHalt hloc) in\n IIf_cons {loc; branch_if_nil; branch_if_cons; k});\n }\n in\n {loc; instr; bef; aft = ibt.aft}\n in\n Lwt.return @@ merge_branches ctxt loc btr bfr {branch}\n | Prim (loc, I_SIZE, [], annot), Item_t (List_t _, rest) ->\n check_var_type_annot loc annot >>?= fun () ->\n let list_size = {apply = (fun k -> IList_size (loc, k))} in\n typed ctxt loc list_size (Item_t (nat_t, rest))\n | Prim (loc, I_MAP, [body], annot), Item_t (List_t (elt, _), starting_rest)\n -> (\n check_kind [Seq_kind] body >>?= fun () ->\n check_var_type_annot loc annot >>?= fun () ->\n non_terminal_recursion tc_context ctxt body (Item_t (elt, starting_rest))\n >>=? fun (judgement, ctxt) ->\n Lwt.return\n @@\n match judgement with\n | Typed ({aft = Item_t (ret, rest) as aft; _} as kibody) ->\n let invalid_map_body () =\n let aft = serialize_stack_for_error ctxt aft in\n Invalid_map_body (loc, aft)\n in\n record_trace_eval\n invalid_map_body\n ( stack_eq loc ctxt 1 rest starting_rest >>? fun (Eq, ctxt) ->\n let hloc = loc in\n let ibody = kibody.instr.apply (IHalt hloc) in\n list_t loc ret >>? fun ty ->\n let list_map =\n {\n apply =\n (fun k -> IList_map (loc, ibody, for_logging_only ty, k));\n }\n in\n let stack = Item_t (ty, rest) in\n typed_no_lwt ctxt loc list_map stack )\n | Typed {aft; _} ->\n let aft = serialize_stack_for_error ctxt aft in\n error (Invalid_map_body (loc, aft))\n | Failed _ -> error (Invalid_map_block_fail loc))\n | Prim (loc, I_ITER, [body], annot), Item_t (List_t (elt, _), rest) -> (\n check_kind [Seq_kind] body >>?= fun () ->\n error_unexpected_annot loc annot >>?= fun () ->\n non_terminal_recursion tc_context ctxt body (Item_t (elt, rest))\n >>=? fun (judgement, ctxt) ->\n let mk_list_iter ibody =\n {\n apply =\n (fun k ->\n let hinfo = loc in\n let ibody = ibody.instr.apply (IHalt hinfo) in\n IList_iter (loc, for_logging_only elt, ibody, k));\n }\n in\n Lwt.return\n @@\n match judgement with\n | Typed ({aft; _} as ibody) ->\n let invalid_iter_body () =\n let aft = serialize_stack_for_error ctxt ibody.aft in\n let rest = serialize_stack_for_error ctxt rest in\n Invalid_iter_body (loc, rest, aft)\n in\n record_trace_eval\n invalid_iter_body\n ( stack_eq loc ctxt 1 aft rest\n >>? fun (Eq, ctxt) : ((a, s) judgement * context) tzresult ->\n typed_no_lwt ctxt loc (mk_list_iter ibody) rest )\n | Failed {descr} -> typed_no_lwt ctxt loc (mk_list_iter (descr rest)) rest\n )\n (* sets *)\n | Prim (loc, I_EMPTY_SET, [t], annot), rest ->\n parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt t\n >>?= fun (Ex_comparable_ty t, ctxt) ->\n check_var_type_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IEmpty_set (loc, t, k))} in\n set_t loc t >>?= fun ty -> typed ctxt loc instr (Item_t (ty, rest))\n | Prim (loc, I_ITER, [body], annot), Item_t (Set_t (elt, _), rest) -> (\n check_kind [Seq_kind] body >>?= fun () ->\n error_unexpected_annot loc annot >>?= fun () ->\n non_terminal_recursion tc_context ctxt body (Item_t (elt, rest))\n >>=? fun (judgement, ctxt) ->\n let mk_iset_iter ibody =\n {\n apply =\n (fun k ->\n let hinfo = loc in\n let ibody = ibody.instr.apply (IHalt hinfo) in\n ISet_iter (loc, for_logging_only elt, ibody, k));\n }\n in\n Lwt.return\n @@\n match judgement with\n | Typed ({aft; _} as ibody) ->\n let invalid_iter_body () =\n let aft = serialize_stack_for_error ctxt ibody.aft in\n let rest = serialize_stack_for_error ctxt rest in\n Invalid_iter_body (loc, rest, aft)\n in\n record_trace_eval\n invalid_iter_body\n ( stack_eq loc ctxt 1 aft rest\n >>? fun (Eq, ctxt) : ((a, s) judgement * context) tzresult ->\n typed_no_lwt ctxt loc (mk_iset_iter ibody) rest )\n | Failed {descr} -> typed_no_lwt ctxt loc (mk_iset_iter (descr rest)) rest\n )\n | Prim (loc, I_MEM, [], annot), Item_t (v, Item_t (Set_t (elt, _), rest)) ->\n check_var_type_annot loc annot >>?= fun () ->\n check_item_ty ctxt elt v loc I_MEM 1 2 >>?= fun (Eq, ctxt) ->\n let instr = {apply = (fun k -> ISet_mem (loc, k))} in\n (typed ctxt loc instr (Item_t (bool_t, rest))\n : ((a, s) judgement * context) tzresult Lwt.t)\n | ( Prim (loc, I_UPDATE, [], annot),\n Item_t (v, Item_t (Bool_t, (Item_t (Set_t (elt, _), _) as stack))) ) ->\n check_item_ty ctxt elt v loc I_UPDATE 1 3 >>?= fun (Eq, ctxt) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ISet_update (loc, k))} in\n (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t)\n | Prim (loc, I_SIZE, [], annot), Item_t (Set_t _, rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ISet_size (loc, k))} in\n typed ctxt loc instr (Item_t (nat_t, rest))\n (* maps *)\n | Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack ->\n parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk\n >>?= fun (Ex_comparable_ty tk, ctxt) ->\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv\n >>?= fun (Ex_ty tv, ctxt) ->\n check_var_type_annot loc annot >>?= fun () ->\n let instr =\n {apply = (fun k -> IEmpty_map (loc, tk, for_logging_only tv, k))}\n in\n map_t loc tk tv >>?= fun ty -> typed ctxt loc instr (Item_t (ty, stack))\n | Prim (loc, I_MAP, [body], annot), Item_t (Map_t (kt, elt, _), starting_rest)\n -> (\n check_kind [Seq_kind] body >>?= fun () ->\n check_var_type_annot loc annot >>?= fun () ->\n pair_t loc kt elt >>?= fun (Ty_ex_c ty) ->\n non_terminal_recursion tc_context ctxt body (Item_t (ty, starting_rest))\n >>=? fun (judgement, ctxt) ->\n Lwt.return\n @@\n match judgement with\n | Typed ({aft = Item_t (ret, rest) as aft; _} as ibody) ->\n let invalid_map_body () =\n let aft = serialize_stack_for_error ctxt aft in\n Invalid_map_body (loc, aft)\n in\n record_trace_eval\n invalid_map_body\n ( stack_eq loc ctxt 1 rest starting_rest >>? fun (Eq, ctxt) ->\n map_t loc kt ret >>? fun ty ->\n let instr =\n {\n apply =\n (fun k ->\n let hinfo = loc in\n let ibody = ibody.instr.apply (IHalt hinfo) in\n IMap_map (loc, for_logging_only ty, ibody, k));\n }\n in\n let stack = Item_t (ty, rest) in\n typed_no_lwt ctxt loc instr stack )\n | Typed {aft; _} ->\n let aft = serialize_stack_for_error ctxt aft in\n error (Invalid_map_body (loc, aft))\n | Failed _ -> error (Invalid_map_block_fail loc))\n | Prim (loc, I_ITER, [body], annot), Item_t (Map_t (key, element_ty, _), rest)\n -> (\n check_kind [Seq_kind] body >>?= fun () ->\n error_unexpected_annot loc annot >>?= fun () ->\n pair_t loc key element_ty >>?= fun (Ty_ex_c ty) ->\n non_terminal_recursion tc_context ctxt body (Item_t (ty, rest))\n >>=? fun (judgement, ctxt) ->\n let make_instr ibody =\n {\n apply =\n (fun k ->\n let hinfo = loc in\n let ibody = ibody.instr.apply (IHalt hinfo) in\n IMap_iter (loc, for_logging_only ty, ibody, k));\n }\n in\n Lwt.return\n @@\n match judgement with\n | Typed ({aft; _} as ibody) ->\n let invalid_iter_body () =\n let aft = serialize_stack_for_error ctxt ibody.aft in\n let rest = serialize_stack_for_error ctxt rest in\n Invalid_iter_body (loc, rest, aft)\n in\n record_trace_eval\n invalid_iter_body\n ( stack_eq loc ctxt 1 aft rest\n >>? fun (Eq, ctxt) : ((a, s) judgement * context) tzresult ->\n typed_no_lwt ctxt loc (make_instr ibody) rest )\n | Failed {descr} -> typed_no_lwt ctxt loc (make_instr (descr rest)) rest)\n | Prim (loc, I_MEM, [], annot), Item_t (vk, Item_t (Map_t (k, _, _), rest)) ->\n check_item_ty ctxt vk k loc I_MEM 1 2 >>?= fun (Eq, ctxt) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IMap_mem (loc, k))} in\n (typed ctxt loc instr (Item_t (bool_t, rest))\n : ((a, s) judgement * context) tzresult Lwt.t)\n | Prim (loc, I_GET, [], annot), Item_t (vk, Item_t (Map_t (k, elt, _), rest))\n ->\n check_item_ty ctxt vk k loc I_GET 1 2 >>?= fun (Eq, ctxt) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IMap_get (loc, k))} in\n option_t loc elt\n >>?= fun ty : ((a, s) judgement * context) tzresult Lwt.t ->\n typed ctxt loc instr (Item_t (ty, rest))\n | ( Prim (loc, I_UPDATE, [], annot),\n Item_t\n ( vk,\n Item_t (Option_t (vv, _, _), (Item_t (Map_t (k, v, _), _) as stack))\n ) ) ->\n check_item_ty ctxt vk k loc I_UPDATE 1 3 >>?= fun (Eq, ctxt) ->\n check_item_ty ctxt vv v loc I_UPDATE 2 3 >>?= fun (Eq, ctxt) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IMap_update (loc, k))} in\n (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t)\n | ( Prim (loc, I_GET_AND_UPDATE, [], annot),\n Item_t\n ( vk,\n (Item_t (Option_t (vv, _, _), Item_t (Map_t (k, v, _), _)) as stack)\n ) ) ->\n check_item_ty ctxt vk k loc I_GET_AND_UPDATE 1 3 >>?= fun (Eq, ctxt) ->\n check_item_ty ctxt vv v loc I_GET_AND_UPDATE 2 3 >>?= fun (Eq, ctxt) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IMap_get_and_update (loc, k))} in\n (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t)\n | Prim (loc, I_SIZE, [], annot), Item_t (Map_t (_, _, _), rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IMap_size (loc, k))} in\n typed ctxt loc instr (Item_t (nat_t, rest))\n (* big_map *)\n | Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack ->\n parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk\n >>?= fun (Ex_comparable_ty tk, ctxt) ->\n parse_big_map_value_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv\n >>?= fun (Ex_ty tv, ctxt) ->\n check_var_type_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IEmpty_big_map (loc, tk, tv, k))} in\n big_map_t loc tk tv >>?= fun ty ->\n let stack = Item_t (ty, stack) in\n typed ctxt loc instr stack\n | ( Prim (loc, I_MEM, [], annot),\n Item_t (set_key, Item_t (Big_map_t (k, _, _), rest)) ) ->\n check_item_ty ctxt set_key k loc I_MEM 1 2 >>?= fun (Eq, ctxt) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IBig_map_mem (loc, k))} in\n let stack = Item_t (bool_t, rest) in\n (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t)\n | ( Prim (loc, I_GET, [], annot),\n Item_t (vk, Item_t (Big_map_t (k, elt, _), rest)) ) ->\n check_item_ty ctxt vk k loc I_GET 1 2 >>?= fun (Eq, ctxt) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IBig_map_get (loc, k))} in\n option_t loc elt >>?= fun ty ->\n let stack = Item_t (ty, rest) in\n (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t)\n | ( Prim (loc, I_UPDATE, [], annot),\n Item_t\n ( set_key,\n Item_t\n ( Option_t (set_value, _, _),\n (Item_t (Big_map_t (map_key, map_value, _), _) as stack) ) ) ) ->\n check_item_ty ctxt set_key map_key loc I_UPDATE 1 3 >>?= fun (Eq, ctxt) ->\n check_item_ty ctxt set_value map_value loc I_UPDATE 2 3\n >>?= fun (Eq, ctxt) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IBig_map_update (loc, k))} in\n (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t)\n | ( Prim (loc, I_GET_AND_UPDATE, [], annot),\n Item_t\n ( vk,\n (Item_t (Option_t (vv, _, _), Item_t (Big_map_t (k, v, _), _)) as\n stack) ) ) ->\n check_item_ty ctxt vk k loc I_GET_AND_UPDATE 1 3 >>?= fun (Eq, ctxt) ->\n check_item_ty ctxt vv v loc I_GET_AND_UPDATE 2 3 >>?= fun (Eq, ctxt) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IBig_map_get_and_update (loc, k))} in\n (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t)\n (* Sapling *)\n | Prim (loc, I_SAPLING_EMPTY_STATE, [memo_size], annot), rest ->\n parse_memo_size memo_size >>?= fun memo_size ->\n check_var_annot loc annot >>?= fun () ->\n let instr =\n {apply = (fun k -> ISapling_empty_state (loc, memo_size, k))}\n in\n let stack = Item_t (sapling_state_t ~memo_size, rest) in\n typed ctxt loc instr stack\n | ( Prim (loc, I_SAPLING_VERIFY_UPDATE, [], _),\n Item_t\n ( Sapling_transaction_deprecated_t transaction_memo_size,\n Item_t ((Sapling_state_t state_memo_size as state_ty), rest) ) ) ->\n if legacy then\n memo_size_eq\n ~error_details:(Informative ())\n state_memo_size\n transaction_memo_size\n >>?= fun () ->\n let instr =\n {apply = (fun k -> ISapling_verify_update_deprecated (loc, k))}\n in\n pair_t loc int_t state_ty >>?= fun (Ty_ex_c pair_ty) ->\n option_t loc pair_ty >>?= fun ty ->\n let stack = Item_t (ty, rest) in\n typed ctxt loc instr stack\n else tzfail (Deprecated_instruction T_sapling_transaction_deprecated)\n | ( Prim (loc, I_SAPLING_VERIFY_UPDATE, [], _),\n Item_t\n ( Sapling_transaction_t transaction_memo_size,\n Item_t ((Sapling_state_t state_memo_size as state_ty), rest) ) ) ->\n memo_size_eq\n ~error_details:(Informative ())\n state_memo_size\n transaction_memo_size\n >>?= fun () ->\n let instr = {apply = (fun k -> ISapling_verify_update (loc, k))} in\n pair_t loc int_t state_ty >>?= fun (Ty_ex_c pair_ty) ->\n pair_t loc bytes_t pair_ty >>?= fun (Ty_ex_c pair_ty) ->\n option_t loc pair_ty >>?= fun ty ->\n let stack = Item_t (ty, rest) in\n typed ctxt loc instr stack\n (* control *)\n | Seq (loc, []), stack ->\n let instr = {apply = (fun k -> k)} in\n typed ctxt loc instr stack\n | Seq (_, [single]), stack ->\n non_terminal_recursion tc_context ctxt single stack\n | Seq (loc, hd :: tl), stack -> (\n non_terminal_recursion tc_context ctxt hd stack\n >>=? fun (judgement, ctxt) ->\n match judgement with\n | Failed _ -> tzfail (Fail_not_in_tail_position (Micheline.location hd))\n | Typed ({aft = middle; _} as ihd) ->\n non_terminal_recursion\n tc_context\n ctxt\n (Seq (Micheline.dummy_location, tl))\n middle\n >|=? fun (judgement, ctxt) ->\n let judgement =\n match judgement with\n | Failed {descr} ->\n let descr ret = compose_descr loc ihd (descr ret) in\n Failed {descr}\n | Typed itl -> Typed (compose_descr loc ihd itl)\n in\n (judgement, ctxt))\n | Prim (loc, I_IF, [bt; bf], annot), (Item_t (Bool_t, rest) as bef) ->\n check_kind [Seq_kind] bt >>?= fun () ->\n check_kind [Seq_kind] bf >>?= fun () ->\n error_unexpected_annot loc annot >>?= fun () ->\n non_terminal_recursion tc_context ctxt bt rest >>=? fun (btr, ctxt) ->\n non_terminal_recursion tc_context ctxt bf rest >>=? fun (bfr, ctxt) ->\n let branch ibt ibf =\n let instr =\n {\n apply =\n (fun k ->\n let hloc = kinstr_location k in\n let branch_if_true = ibt.instr.apply (IHalt hloc)\n and branch_if_false = ibf.instr.apply (IHalt hloc) in\n IIf {loc; branch_if_true; branch_if_false; k});\n }\n in\n {loc; instr; bef; aft = ibt.aft}\n in\n Lwt.return @@ merge_branches ctxt loc btr bfr {branch}\n | Prim (loc, I_LOOP, [body], annot), (Item_t (Bool_t, rest) as stack) -> (\n check_kind [Seq_kind] body >>?= fun () ->\n error_unexpected_annot loc annot >>?= fun () ->\n non_terminal_recursion tc_context ctxt body rest\n >>=? fun (judgement, ctxt) ->\n Lwt.return\n @@\n match judgement with\n | Typed ibody ->\n let unmatched_branches () =\n let aft = serialize_stack_for_error ctxt ibody.aft in\n let stack = serialize_stack_for_error ctxt stack in\n Unmatched_branches (loc, aft, stack)\n in\n record_trace_eval\n unmatched_branches\n ( stack_eq loc ctxt 1 ibody.aft stack >>? fun (Eq, ctxt) ->\n let instr =\n {\n apply =\n (fun k ->\n let loc = kinstr_location k in\n let ibody = ibody.instr.apply (IHalt loc) in\n ILoop (loc, ibody, k));\n }\n in\n typed_no_lwt ctxt loc instr rest )\n | Failed {descr} ->\n let instr =\n {\n apply =\n (fun k ->\n let loc = kinstr_location k in\n let ibody = descr stack in\n let ibody = ibody.instr.apply (IHalt loc) in\n ILoop (loc, ibody, k));\n }\n in\n typed_no_lwt ctxt loc instr rest)\n | ( Prim (loc, I_LOOP_LEFT, [body], annot),\n (Item_t (Union_t (tl, tr, _, _), rest) as stack) ) -> (\n check_kind [Seq_kind] body >>?= fun () ->\n check_var_annot loc annot >>?= fun () ->\n non_terminal_recursion tc_context ctxt body (Item_t (tl, rest))\n >>=? fun (judgement, ctxt) ->\n Lwt.return\n @@\n match judgement with\n | Typed ibody ->\n let unmatched_branches () =\n let aft = serialize_stack_for_error ctxt ibody.aft in\n let stack = serialize_stack_for_error ctxt stack in\n Unmatched_branches (loc, aft, stack)\n in\n record_trace_eval\n unmatched_branches\n ( stack_eq loc ctxt 1 ibody.aft stack >>? fun (Eq, ctxt) ->\n let instr =\n {\n apply =\n (fun k ->\n let loc = kinstr_location k in\n let ibody = ibody.instr.apply (IHalt loc) in\n ILoop_left (loc, ibody, k));\n }\n in\n let stack = Item_t (tr, rest) in\n typed_no_lwt ctxt loc instr stack )\n | Failed {descr} ->\n let instr =\n {\n apply =\n (fun k ->\n let loc = kinstr_location k in\n let ibody = descr stack in\n let ibody = ibody.instr.apply (IHalt loc) in\n ILoop_left (loc, ibody, k));\n }\n in\n let stack = Item_t (tr, rest) in\n typed_no_lwt ctxt loc instr stack)\n | Prim (loc, I_LAMBDA, [arg; ret; code], annot), stack ->\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy arg\n >>?= fun (Ex_ty arg, ctxt) ->\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ret\n >>?= fun (Ex_ty ret, ctxt) ->\n check_kind [Seq_kind] code >>?= fun () ->\n check_var_annot loc annot >>?= fun () ->\n parse_kdescr\n ~unparse_code_rec\n (Tc_context.add_lambda tc_context)\n ~elab_conf\n ~stack_depth:(stack_depth + 1)\n ctxt\n arg\n ret\n code\n >>=? fun (kdescr, ctxt) ->\n (* No need to normalize the unparsed component to Optimized mode here\n because the script is already normalized in Optimized mode. *)\n let instr = {apply = (fun k -> ILambda (loc, Lam (kdescr, code), k))} in\n lambda_t loc arg ret >>?= fun ty ->\n let stack = Item_t (ty, stack) in\n typed ctxt loc instr stack\n | ( Prim (loc, I_LAMBDA_REC, [arg_ty_expr; ret_ty_expr; lambda_expr], annot),\n stack ) ->\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy arg_ty_expr\n >>?= fun (Ex_ty arg, ctxt) ->\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ret_ty_expr\n >>?= fun (Ex_ty ret, ctxt) ->\n check_kind [Seq_kind] lambda_expr >>?= fun () ->\n check_var_annot loc annot >>?= fun () ->\n lambda_t loc arg ret >>?= fun lambda_rec_ty ->\n parse_lam_rec\n ~unparse_code_rec:(fun ctxt ~stack_depth:_ _unparsing_mode node ->\n return (node, ctxt))\n (* No need to normalize the unparsed component to Optimized mode here\n because the script is already normalized in Optimized mode. *)\n Tc_context.(add_lambda tc_context)\n ~elab_conf\n ~stack_depth:(stack_depth + 1)\n ctxt\n arg\n ret\n lambda_rec_ty\n lambda_expr\n >>=? fun (code, ctxt) ->\n let instr = {apply = (fun k -> ILambda (loc, code, k))} in\n let stack = Item_t (lambda_rec_ty, stack) in\n typed ctxt loc instr stack\n | ( Prim (loc, I_EXEC, [], annot),\n Item_t (arg, Item_t (Lambda_t (param, ret, _), rest)) ) ->\n check_item_ty ctxt arg param loc I_EXEC 1 2 >>?= fun (Eq, ctxt) ->\n check_var_annot loc annot >>?= fun () ->\n let stack = Item_t (ret, rest) in\n let instr = {apply = (fun k -> IExec (loc, for_logging_only stack, k))} in\n (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t)\n | ( Prim (loc, I_APPLY, [], annot),\n Item_t\n ( capture,\n Item_t (Lambda_t (Pair_t (capture_ty, arg_ty, _, _), ret, _), rest) )\n ) ->\n check_packable ~legacy:false loc capture_ty >>?= fun () ->\n check_item_ty ctxt capture capture_ty loc I_APPLY 1 2\n >>?= fun (Eq, ctxt) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IApply (loc, capture_ty, k))} in\n lambda_t loc arg_ty ret\n (* This cannot tzfail because the type [lambda 'arg 'ret] is always smaller than\n the input type [lambda (pair 'arg 'capture) 'ret]. In an ideal world, there\n would be a smart deconstructor to ensure this statically. *)\n >>?=\n fun res_ty ->\n let stack = Item_t (res_ty, rest) in\n (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t)\n | Prim (loc, I_DIP, [code], annot), Item_t (v, rest) -> (\n error_unexpected_annot loc annot >>?= fun () ->\n check_kind [Seq_kind] code >>?= fun () ->\n non_terminal_recursion tc_context ctxt code rest\n >>=? fun (judgement, ctxt) ->\n match judgement with\n | Typed descr ->\n let instr =\n {\n apply =\n (fun k ->\n let b = descr.instr.apply (IHalt descr.loc) in\n IDip (loc, b, for_logging_only v, k));\n }\n in\n let stack = Item_t (v, descr.aft) in\n typed ctxt loc instr stack\n | Failed _ -> tzfail (Fail_not_in_tail_position loc))\n | Prim (loc, I_DIP, [n; code], result_annot), stack ->\n parse_uint10 n >>?= fun n ->\n Gas.consume ctxt (Typecheck_costs.proof_argument n) >>?= fun ctxt ->\n let rec make_proof_argument :\n type a s.\n int -> (a, s) stack_ty -> (a, s) dipn_proof_argument tzresult Lwt.t =\n fun n stk ->\n match (Compare.Int.(n = 0), stk) with\n | true, rest -> (\n non_terminal_recursion tc_context ctxt code rest\n >>=? fun (judgement, ctxt) ->\n Lwt.return\n @@\n match judgement with\n | Typed descr ->\n ok\n (Dipn_proof_argument (KRest, ctxt, descr, descr.aft)\n : (a, s) dipn_proof_argument)\n | Failed _ -> error (Fail_not_in_tail_position loc))\n | false, Item_t (v, rest) ->\n make_proof_argument (n - 1) rest\n >|=? fun (Dipn_proof_argument (n', ctxt, descr, aft')) ->\n let w = KPrefix (loc, v, n') in\n Dipn_proof_argument (w, ctxt, descr, Item_t (v, aft'))\n | _, _ ->\n Lwt.return\n (let whole_stack = serialize_stack_for_error ctxt stack in\n error (Bad_stack (loc, I_DIP, 1, whole_stack)))\n in\n error_unexpected_annot loc result_annot >>?= fun () ->\n make_proof_argument n stack\n >>=? fun (Dipn_proof_argument (n', ctxt, descr, aft)) ->\n let b = descr.instr.apply (IHalt descr.loc) in\n let res = {apply = (fun k -> IDipn (loc, n, n', b, k))} in\n typed ctxt loc res aft\n | Prim (loc, I_DIP, (([] | _ :: _ :: _ :: _) as l), _), _ ->\n (* Technically, the arities 1 and 2 are allowed but the error only mentions 2.\n However, DIP {code} is equivalent to DIP 1 {code} so hinting at an arity of 2 makes sense. *)\n tzfail (Invalid_arity (loc, I_DIP, 2, List.length l))\n | Prim (loc, I_FAILWITH, [], annot), Item_t (v, _rest) ->\n Lwt.return\n ( error_unexpected_annot loc annot >>? fun () ->\n (if legacy then Result.return_unit\n else check_packable ~legacy:false loc v)\n >|? fun () ->\n let instr = {apply = (fun _k -> IFailwith (loc, v))} in\n let descr aft = {loc; instr; bef = stack_ty; aft} in\n log_stack loc stack_ty Bot_t ;\n (Failed {descr}, ctxt) )\n | Prim (loc, I_NEVER, [], annot), Item_t (Never_t, _rest) ->\n Lwt.return\n ( error_unexpected_annot loc annot >|? fun () ->\n let instr = {apply = (fun _k -> INever loc)} in\n let descr aft = {loc; instr; bef = stack_ty; aft} in\n log_stack loc stack_ty Bot_t ;\n (Failed {descr}, ctxt) )\n (* timestamp operations *)\n | Prim (loc, I_ADD, [], annot), Item_t (Timestamp_t, Item_t (Int_t, rest)) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IAdd_timestamp_to_seconds (loc, k))} in\n typed ctxt loc instr (Item_t (Timestamp_t, rest))\n | ( Prim (loc, I_ADD, [], annot),\n Item_t (Int_t, (Item_t (Timestamp_t, _) as stack)) ) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IAdd_seconds_to_timestamp (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_SUB, [], annot), Item_t (Timestamp_t, Item_t (Int_t, rest)) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ISub_timestamp_seconds (loc, k))} in\n let stack = Item_t (Timestamp_t, rest) in\n typed ctxt loc instr stack\n | ( Prim (loc, I_SUB, [], annot),\n Item_t (Timestamp_t, Item_t (Timestamp_t, rest)) ) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IDiff_timestamps (loc, k))} in\n let stack = Item_t (int_t, rest) in\n typed ctxt loc instr stack\n (* string operations *)\n | ( Prim (loc, I_CONCAT, [], annot),\n Item_t (String_t, (Item_t (String_t, _) as stack)) ) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IConcat_string_pair (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_CONCAT, [], annot), Item_t (List_t (String_t, _), rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IConcat_string (loc, k))} in\n typed ctxt loc instr (Item_t (String_t, rest))\n | ( Prim (loc, I_SLICE, [], annot),\n Item_t (Nat_t, Item_t (Nat_t, Item_t (String_t, rest))) ) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ISlice_string (loc, k))} in\n let stack = Item_t (option_string_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_SIZE, [], annot), Item_t (String_t, rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IString_size (loc, k))} in\n let stack = Item_t (nat_t, rest) in\n typed ctxt loc instr stack\n (* bytes operations *)\n | ( Prim (loc, I_CONCAT, [], annot),\n Item_t (Bytes_t, (Item_t (Bytes_t, _) as stack)) ) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IConcat_bytes_pair (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_CONCAT, [], annot), Item_t (List_t (Bytes_t, _), rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IConcat_bytes (loc, k))} in\n let stack = Item_t (Bytes_t, rest) in\n typed ctxt loc instr stack\n | ( Prim (loc, I_SLICE, [], annot),\n Item_t (Nat_t, Item_t (Nat_t, Item_t (Bytes_t, rest))) ) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ISlice_bytes (loc, k))} in\n let stack = Item_t (option_bytes_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_SIZE, [], annot), Item_t (Bytes_t, rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IBytes_size (loc, k))} in\n let stack = Item_t (nat_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_BYTES, [], annot), Item_t (Nat_t, rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IBytes_nat (loc, k))} in\n let stack = Item_t (bytes_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_NAT, [], annot), Item_t (Bytes_t, rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> INat_bytes (loc, k))} in\n let stack = Item_t (nat_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_BYTES, [], annot), Item_t (Int_t, rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IBytes_int (loc, k))} in\n let stack = Item_t (bytes_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_INT, [], annot), Item_t (Bytes_t, rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IInt_bytes (loc, k))} in\n let stack = Item_t (int_t, rest) in\n typed ctxt loc instr stack\n (* currency operations *)\n | ( Prim (loc, I_ADD, [], annot),\n Item_t (Mutez_t, (Item_t (Mutez_t, _) as stack)) ) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IAdd_tez (loc, k))} in\n typed ctxt loc instr stack\n | ( Prim (loc, I_SUB, [], annot),\n Item_t (Mutez_t, (Item_t (Mutez_t, _) as stack)) ) ->\n if legacy then\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ISub_tez_legacy (loc, k))} in\n typed ctxt loc instr stack\n else tzfail (Deprecated_instruction I_SUB)\n | Prim (loc, I_SUB_MUTEZ, [], annot), Item_t (Mutez_t, Item_t (Mutez_t, rest))\n ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ISub_tez (loc, k))} in\n let stack = Item_t (option_mutez_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_MUL, [], annot), Item_t (Mutez_t, Item_t (Nat_t, rest)) ->\n (* no type name check *)\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IMul_teznat (loc, k))} in\n let stack = Item_t (Mutez_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_MUL, [], annot), Item_t (Nat_t, (Item_t (Mutez_t, _) as stack))\n ->\n (* no type name check *)\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IMul_nattez (loc, k))} in\n typed ctxt loc instr stack\n (* boolean operations *)\n | Prim (loc, I_OR, [], annot), Item_t (Bool_t, (Item_t (Bool_t, _) as stack))\n ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IOr (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_AND, [], annot), Item_t (Bool_t, (Item_t (Bool_t, _) as stack))\n ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IAnd (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_XOR, [], annot), Item_t (Bool_t, (Item_t (Bool_t, _) as stack))\n ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IXor (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_NOT, [], annot), (Item_t (Bool_t, _) as stack) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> INot (loc, k))} in\n typed ctxt loc instr stack\n (* integer operations *)\n | Prim (loc, I_ABS, [], annot), Item_t (Int_t, rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IAbs_int (loc, k))} in\n let stack = Item_t (nat_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_ISNAT, [], annot), Item_t (Int_t, rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IIs_nat (loc, k))} in\n let stack = Item_t (option_nat_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_INT, [], annot), Item_t (Nat_t, rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IInt_nat (loc, k))} in\n let stack = Item_t (int_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_NEG, [], annot), (Item_t (Int_t, _) as stack) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> INeg (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_NEG, [], annot), Item_t (Nat_t, rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> INeg (loc, k))} in\n let stack = Item_t (int_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_ADD, [], annot), Item_t (Int_t, (Item_t (Int_t, _) as stack))\n ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IAdd_int (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_ADD, [], annot), Item_t (Int_t, Item_t (Nat_t, rest)) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IAdd_int (loc, k))} in\n let stack = Item_t (Int_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_ADD, [], annot), Item_t (Nat_t, (Item_t (Int_t, _) as stack))\n ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IAdd_int (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_ADD, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack))\n ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IAdd_nat (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_SUB, [], annot), Item_t (Int_t, (Item_t (Int_t, _) as stack))\n ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ISub_int (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_SUB, [], annot), Item_t (Int_t, Item_t (Nat_t, rest)) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ISub_int (loc, k))} in\n let stack = Item_t (Int_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_SUB, [], annot), Item_t (Nat_t, (Item_t (Int_t, _) as stack))\n ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ISub_int (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_SUB, [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ISub_int (loc, k))} in\n let stack = Item_t (int_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_MUL, [], annot), Item_t (Int_t, (Item_t (Int_t, _) as stack))\n ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IMul_int (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_MUL, [], annot), Item_t (Int_t, Item_t (Nat_t, rest)) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IMul_int (loc, k))} in\n let stack = Item_t (Int_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_MUL, [], annot), Item_t (Nat_t, (Item_t (Int_t, _) as stack))\n ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IMul_nat (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_MUL, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack))\n ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IMul_nat (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_EDIV, [], annot), Item_t (Mutez_t, Item_t (Nat_t, rest)) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IEdiv_teznat (loc, k))} in\n let stack = Item_t (option_pair_mutez_mutez_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_EDIV, [], annot), Item_t (Mutez_t, Item_t (Mutez_t, rest)) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IEdiv_tez (loc, k))} in\n let stack = Item_t (option_pair_nat_mutez_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_EDIV, [], annot), Item_t (Int_t, Item_t (Int_t, rest)) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IEdiv_int (loc, k))} in\n let stack = Item_t (option_pair_int_nat_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_EDIV, [], annot), Item_t (Int_t, Item_t (Nat_t, rest)) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IEdiv_int (loc, k))} in\n let stack = Item_t (option_pair_int_nat_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_EDIV, [], annot), Item_t (Nat_t, Item_t (Int_t, rest)) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IEdiv_nat (loc, k))} in\n let stack = Item_t (option_pair_int_nat_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_EDIV, [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IEdiv_nat (loc, k))} in\n let stack = Item_t (option_pair_nat_nat_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_LSL, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack))\n ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ILsl_nat (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_LSL, [], annot), Item_t (Bytes_t, Item_t (Nat_t, rest)) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ILsl_bytes (loc, k))} in\n let stack = Item_t (Bytes_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_LSR, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack))\n ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ILsr_nat (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_LSR, [], annot), Item_t (Bytes_t, Item_t (Nat_t, rest)) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ILsr_bytes (loc, k))} in\n let stack = Item_t (Bytes_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_OR, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack)) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IOr_nat (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_OR, [], annot), Item_t (Bytes_t, (Item_t (Bytes_t, _) as stack))\n ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IOr_bytes (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_AND, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack))\n ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IAnd_nat (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_AND, [], annot), Item_t (Int_t, (Item_t (Nat_t, _) as stack))\n ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IAnd_int_nat (loc, k))} in\n typed ctxt loc instr stack\n | ( Prim (loc, I_AND, [], annot),\n Item_t (Bytes_t, (Item_t (Bytes_t, _) as stack)) ) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IAnd_bytes (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_XOR, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack))\n ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IXor_nat (loc, k))} in\n typed ctxt loc instr stack\n | ( Prim (loc, I_XOR, [], annot),\n Item_t (Bytes_t, (Item_t (Bytes_t, _) as stack)) ) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IXor_bytes (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_NOT, [], annot), (Item_t (Int_t, _) as stack) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> INot_int (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_NOT, [], annot), Item_t (Nat_t, rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> INot_int (loc, k))} in\n let stack = Item_t (int_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_NOT, [], annot), (Item_t (Bytes_t, _) as stack) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> INot_bytes (loc, k))} in\n typed ctxt loc instr stack\n (* comparison *)\n | Prim (loc, I_COMPARE, [], annot), Item_t (t1, Item_t (t2, rest)) ->\n check_var_annot loc annot >>?= fun () ->\n check_item_ty ctxt t1 t2 loc I_COMPARE 1 2 >>?= fun (Eq, ctxt) ->\n check_comparable loc t1 >>?= fun Eq ->\n let instr = {apply = (fun k -> ICompare (loc, t1, k))} in\n let stack = Item_t (int_t, rest) in\n (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t)\n (* comparators *)\n | Prim (loc, I_EQ, [], annot), Item_t (Int_t, rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IEq (loc, k))} in\n let stack = Item_t (bool_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_NEQ, [], annot), Item_t (Int_t, rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> INeq (loc, k))} in\n let stack = Item_t (bool_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_LT, [], annot), Item_t (Int_t, rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ILt (loc, k))} in\n let stack = Item_t (bool_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_GT, [], annot), Item_t (Int_t, rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IGt (loc, k))} in\n let stack = Item_t (bool_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_LE, [], annot), Item_t (Int_t, rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ILe (loc, k))} in\n let stack = Item_t (bool_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_GE, [], annot), Item_t (Int_t, rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IGe (loc, k))} in\n let stack = Item_t (bool_t, rest) in\n typed ctxt loc instr stack\n (* annotations *)\n | Prim (loc, I_CAST, [cast_t], annot), (Item_t (t, _) as stack) ->\n check_var_annot loc annot >>?= fun () ->\n parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy cast_t\n >>?= fun (Ex_ty cast_t, ctxt) ->\n Gas_monad.run ctxt @@ ty_eq ~error_details:(Informative loc) cast_t t\n >>?= fun (eq, ctxt) ->\n eq >>?= fun Eq ->\n (* We can reuse [stack] because [a ty = b ty] means [a = b]. *)\n let instr = {apply = (fun k -> k)} in\n (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t)\n | Prim (loc, I_RENAME, [], annot), (Item_t _ as stack) ->\n check_var_annot loc annot >>?= fun () ->\n (* can erase annot *)\n let instr = {apply = (fun k -> k)} in\n typed ctxt loc instr stack\n (* packing *)\n | Prim (loc, I_PACK, [], annot), Item_t (t, rest) ->\n check_packable\n ~legacy:true\n (* allow to pack contracts for hash/signature checks *) loc\n t\n >>?= fun () ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IPack (loc, t, k))} in\n let stack = Item_t (bytes_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_UNPACK, [ty], annot), Item_t (Bytes_t, rest) ->\n parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty\n >>?= fun (Ex_ty t, ctxt) ->\n check_var_type_annot loc annot >>?= fun () ->\n option_t loc t >>?= fun res_ty ->\n let instr = {apply = (fun k -> IUnpack (loc, t, k))} in\n let stack = Item_t (res_ty, rest) in\n typed ctxt loc instr stack\n (* protocol *)\n | Prim (loc, I_ADDRESS, [], annot), Item_t (Contract_t _, rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IAddress (loc, k))} in\n let stack = Item_t (address_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_CONTRACT, [ty], annot), Item_t (Address_t, rest) ->\n parse_passable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty\n >>?= fun (Ex_ty t, ctxt) ->\n contract_t loc t >>?= fun contract_ty ->\n option_t loc contract_ty >>?= fun res_ty ->\n parse_entrypoint_annot_strict loc annot >>?= fun entrypoint ->\n let instr = {apply = (fun k -> IContract (loc, t, entrypoint, k))} in\n let stack = Item_t (res_ty, rest) in\n typed ctxt loc instr stack\n | ( Prim (loc, I_VIEW, [name; output_ty], annot),\n Item_t (input_ty, Item_t (Address_t, rest)) ) ->\n let output_ty_loc = location output_ty in\n parse_view_name ctxt name >>?= fun (name, ctxt) ->\n parse_view_output_ty ctxt ~stack_depth:0 ~legacy output_ty\n >>?= fun (Ex_ty output_ty, ctxt) ->\n option_t output_ty_loc output_ty >>?= fun res_ty ->\n check_var_annot loc annot >>?= fun () ->\n let instr =\n {\n apply =\n (fun k ->\n IView\n ( loc,\n View_signature {name; input_ty; output_ty},\n for_logging_only rest,\n k ));\n }\n in\n let stack = Item_t (res_ty, rest) in\n typed ctxt loc instr stack\n | ( Prim (loc, (I_TRANSFER_TOKENS as prim), [], annot),\n Item_t (p, Item_t (Mutez_t, Item_t (Contract_t (cp, _), rest))) ) ->\n Tc_context.check_not_in_view loc ~legacy tc_context prim >>?= fun () ->\n check_item_ty ctxt p cp loc prim 1 4 >>?= fun (Eq, ctxt) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ITransfer_tokens (loc, k))} in\n let stack = Item_t (operation_t, rest) in\n (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t)\n | ( Prim (loc, (I_SET_DELEGATE as prim), [], annot),\n Item_t (Option_t (Key_hash_t, _, _), rest) ) ->\n Tc_context.check_not_in_view loc ~legacy tc_context prim >>?= fun () ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ISet_delegate (loc, k))} in\n let stack = Item_t (operation_t, rest) in\n typed ctxt loc instr stack\n | Prim (_, I_CREATE_ACCOUNT, _, _), _ ->\n tzfail (Deprecated_instruction I_CREATE_ACCOUNT)\n | Prim (loc, I_IMPLICIT_ACCOUNT, [], annot), Item_t (Key_hash_t, rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IImplicit_account (loc, k))} in\n let stack = Item_t (contract_unit_t, rest) in\n typed ctxt loc instr stack\n | ( Prim (loc, (I_CREATE_CONTRACT as prim), [(Seq _ as code)], annot),\n Item_t\n (Option_t (Key_hash_t, _, _), Item_t (Mutez_t, Item_t (ginit, rest))) )\n -> (\n Tc_context.check_not_in_view ~legacy loc tc_context prim >>?= fun () ->\n check_two_var_annot loc annot >>?= fun () ->\n (* We typecheck the script to make sure we will originate only well-typed\n contracts but then we throw away the typed version, except for the\n storage type which is kept for efficiency in the ticket scanner. *)\n let canonical_code = Micheline.strip_locations code in\n parse_toplevel ctxt ~legacy canonical_code\n >>?= fun ({arg_type; storage_type; code_field; views}, ctxt) ->\n record_trace\n (Ill_formed_type (Some \"parameter\", canonical_code, location arg_type))\n (parse_parameter_ty_and_entrypoints\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy\n arg_type)\n >>?= fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt)\n ->\n record_trace\n (Ill_formed_type (Some \"storage\", canonical_code, location storage_type))\n (parse_storage_ty\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy\n storage_type)\n >>?= fun (Ex_ty storage_type, ctxt) ->\n pair_t loc arg_type storage_type >>?= fun (Ty_ex_c arg_type_full) ->\n pair_t loc list_operation_t storage_type\n >>?= fun (Ty_ex_c ret_type_full) ->\n trace\n (Ill_typed_contract (canonical_code, []))\n (parse_kdescr\n ~unparse_code_rec\n (Tc_context.toplevel ~storage_type ~param_type:arg_type ~entrypoints)\n ctxt\n ~elab_conf\n ~stack_depth:(stack_depth + 1)\n arg_type_full\n ret_type_full\n code_field)\n >>=? function\n | {kbef = Item_t (arg, Bot_t); kaft = Item_t (ret, Bot_t); _}, ctxt ->\n let views_result =\n parse_views ~unparse_code_rec ctxt ~elab_conf storage_type views\n in\n trace (Ill_typed_contract (canonical_code, [])) views_result\n >>=? fun (_typed_views, ctxt) ->\n (let error_details = Informative loc in\n Gas_monad.run ctxt\n @@\n let open Gas_monad.Syntax in\n let* Eq = ty_eq ~error_details arg arg_type_full in\n let* Eq = ty_eq ~error_details ret ret_type_full in\n ty_eq ~error_details storage_type ginit)\n >>?= fun (storage_eq, ctxt) ->\n storage_eq >>?= fun Eq ->\n let instr =\n {\n apply =\n (fun k ->\n ICreate_contract {loc; storage_type; code = canonical_code; k});\n }\n in\n let stack = Item_t (operation_t, Item_t (address_t, rest)) in\n typed ctxt loc instr stack)\n | Prim (loc, I_NOW, [], annot), stack ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> INow (loc, k))} in\n let stack = Item_t (timestamp_t, stack) in\n typed ctxt loc instr stack\n | Prim (loc, I_MIN_BLOCK_TIME, [], _), stack ->\n typed\n ctxt\n loc\n {apply = (fun k -> IMin_block_time (loc, k))}\n (Item_t (nat_t, stack))\n | Prim (loc, I_AMOUNT, [], annot), stack ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IAmount (loc, k))} in\n let stack = Item_t (mutez_t, stack) in\n typed ctxt loc instr stack\n | Prim (loc, I_CHAIN_ID, [], annot), stack ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IChainId (loc, k))} in\n let stack = Item_t (chain_id_t, stack) in\n typed ctxt loc instr stack\n | Prim (loc, I_BALANCE, [], annot), stack ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IBalance (loc, k))} in\n let stack = Item_t (mutez_t, stack) in\n typed ctxt loc instr stack\n | Prim (loc, I_LEVEL, [], annot), stack ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ILevel (loc, k))} in\n let stack = Item_t (nat_t, stack) in\n typed ctxt loc instr stack\n | Prim (loc, I_VOTING_POWER, [], annot), Item_t (Key_hash_t, rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IVoting_power (loc, k))} in\n let stack = Item_t (nat_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_TOTAL_VOTING_POWER, [], annot), stack ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ITotal_voting_power (loc, k))} in\n let stack = Item_t (nat_t, stack) in\n typed ctxt loc instr stack\n | Prim (_, I_STEPS_TO_QUOTA, _, _), _ ->\n tzfail (Deprecated_instruction I_STEPS_TO_QUOTA)\n | Prim (loc, I_SOURCE, [], annot), stack ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ISource (loc, k))} in\n let stack = Item_t (address_t, stack) in\n typed ctxt loc instr stack\n | Prim (loc, I_SENDER, [], annot), stack ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ISender (loc, k))} in\n let stack = Item_t (address_t, stack) in\n typed ctxt loc instr stack\n | Prim (loc, (I_SELF as prim), [], annot), stack ->\n Lwt.return\n ( parse_entrypoint_annot_lax loc annot >>? fun entrypoint ->\n let open Tc_context in\n match tc_context.callsite with\n | _ when is_in_lambda tc_context ->\n error\n (Forbidden_instr_in_context (loc, Script_tc_errors.Lambda, prim))\n (* [Data] is for pushed instructions of lambda type. *)\n | Data ->\n error\n (Forbidden_instr_in_context (loc, Script_tc_errors.Lambda, prim))\n | View ->\n error\n (Forbidden_instr_in_context (loc, Script_tc_errors.View, prim))\n | Toplevel {param_type; entrypoints; storage_type = _} ->\n Gas_monad.run ctxt\n @@ find_entrypoint\n ~error_details:(Informative ())\n param_type\n entrypoints\n entrypoint\n >>? fun (r, ctxt) ->\n r >>? fun (Ex_ty_cstr {ty = param_type; _}) ->\n contract_t loc param_type >>? fun res_ty ->\n let instr =\n {apply = (fun k -> ISelf (loc, param_type, entrypoint, k))}\n in\n let stack = Item_t (res_ty, stack) in\n typed_no_lwt ctxt loc instr stack )\n | Prim (loc, I_SELF_ADDRESS, [], annot), stack ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ISelf_address (loc, k))} in\n let stack = Item_t (address_t, stack) in\n typed ctxt loc instr stack\n (* cryptography *)\n | Prim (loc, I_HASH_KEY, [], annot), Item_t (Key_t, rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IHash_key (loc, k))} in\n let stack = Item_t (key_hash_t, rest) in\n typed ctxt loc instr stack\n | ( Prim (loc, I_CHECK_SIGNATURE, [], annot),\n Item_t (Key_t, Item_t (Signature_t, Item_t (Bytes_t, rest))) ) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ICheck_signature (loc, k))} in\n let stack = Item_t (bool_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_BLAKE2B, [], annot), (Item_t (Bytes_t, _) as stack) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IBlake2b (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_SHA256, [], annot), (Item_t (Bytes_t, _) as stack) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ISha256 (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_SHA512, [], annot), (Item_t (Bytes_t, _) as stack) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ISha512 (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_KECCAK, [], annot), (Item_t (Bytes_t, _) as stack) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IKeccak (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_SHA3, [], annot), (Item_t (Bytes_t, _) as stack) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> ISha3 (loc, k))} in\n typed ctxt loc instr stack\n | ( Prim (loc, I_ADD, [], annot),\n Item_t (Bls12_381_g1_t, (Item_t (Bls12_381_g1_t, _) as stack)) ) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IAdd_bls12_381_g1 (loc, k))} in\n typed ctxt loc instr stack\n | ( Prim (loc, I_ADD, [], annot),\n Item_t (Bls12_381_g2_t, (Item_t (Bls12_381_g2_t, _) as stack)) ) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IAdd_bls12_381_g2 (loc, k))} in\n typed ctxt loc instr stack\n | ( Prim (loc, I_ADD, [], annot),\n Item_t (Bls12_381_fr_t, (Item_t (Bls12_381_fr_t, _) as stack)) ) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IAdd_bls12_381_fr (loc, k))} in\n typed ctxt loc instr stack\n | ( Prim (loc, I_MUL, [], annot),\n Item_t (Bls12_381_g1_t, Item_t (Bls12_381_fr_t, rest)) ) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IMul_bls12_381_g1 (loc, k))} in\n let stack = Item_t (Bls12_381_g1_t, rest) in\n typed ctxt loc instr stack\n | ( Prim (loc, I_MUL, [], annot),\n Item_t (Bls12_381_g2_t, Item_t (Bls12_381_fr_t, rest)) ) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IMul_bls12_381_g2 (loc, k))} in\n let stack = Item_t (Bls12_381_g2_t, rest) in\n typed ctxt loc instr stack\n | ( Prim (loc, I_MUL, [], annot),\n Item_t (Bls12_381_fr_t, (Item_t (Bls12_381_fr_t, _) as stack)) ) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IMul_bls12_381_fr (loc, k))} in\n typed ctxt loc instr stack\n | ( Prim (loc, I_MUL, [], annot),\n Item_t (Nat_t, (Item_t (Bls12_381_fr_t, _) as stack)) ) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IMul_bls12_381_fr_z (loc, k))} in\n typed ctxt loc instr stack\n | ( Prim (loc, I_MUL, [], annot),\n Item_t (Int_t, (Item_t (Bls12_381_fr_t, _) as stack)) ) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IMul_bls12_381_fr_z (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_MUL, [], annot), Item_t (Bls12_381_fr_t, Item_t (Int_t, rest))\n ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IMul_bls12_381_z_fr (loc, k))} in\n let stack = Item_t (Bls12_381_fr_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_MUL, [], annot), Item_t (Bls12_381_fr_t, Item_t (Nat_t, rest))\n ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IMul_bls12_381_z_fr (loc, k))} in\n let stack = Item_t (Bls12_381_fr_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_INT, [], annot), Item_t (Bls12_381_fr_t, rest) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IInt_bls12_381_fr (loc, k))} in\n let stack = Item_t (int_t, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_NEG, [], annot), (Item_t (Bls12_381_g1_t, _) as stack) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> INeg_bls12_381_g1 (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_NEG, [], annot), (Item_t (Bls12_381_g2_t, _) as stack) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> INeg_bls12_381_g2 (loc, k))} in\n typed ctxt loc instr stack\n | Prim (loc, I_NEG, [], annot), (Item_t (Bls12_381_fr_t, _) as stack) ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> INeg_bls12_381_fr (loc, k))} in\n typed ctxt loc instr stack\n | ( Prim (loc, I_PAIRING_CHECK, [], annot),\n Item_t (List_t (Pair_t (Bls12_381_g1_t, Bls12_381_g2_t, _, _), _), rest) )\n ->\n check_var_annot loc annot >>?= fun () ->\n let instr = {apply = (fun k -> IPairing_check_bls12_381 (loc, k))} in\n let stack = Item_t (bool_t, rest) in\n typed ctxt loc instr stack\n (* Tickets *)\n | Prim (loc, I_TICKET, [], annot), Item_t (t, Item_t (Nat_t, rest)) ->\n check_var_annot loc annot >>?= fun () ->\n check_comparable loc t >>?= fun Eq ->\n ticket_t loc t >>?= fun res_ty ->\n let instr = {apply = (fun k -> ITicket (loc, for_logging_only t, k))} in\n option_t loc res_ty >>?= fun res_ty ->\n let stack = Item_t (res_ty, rest) in\n typed ctxt loc instr stack\n | Prim (loc, I_TICKET_DEPRECATED, [], annot), Item_t (t, Item_t (Nat_t, rest))\n ->\n if legacy then\n check_var_annot loc annot >>?= fun () ->\n check_comparable loc t >>?= fun Eq ->\n ticket_t loc t >>?= fun res_ty ->\n let instr =\n {apply = (fun k -> ITicket_deprecated (loc, for_logging_only t, k))}\n in\n let stack = Item_t (res_ty, rest) in\n typed ctxt loc instr stack\n else tzfail (Deprecated_instruction I_TICKET_DEPRECATED)\n | ( Prim (loc, I_READ_TICKET, [], annot),\n (Item_t (Ticket_t (t, _), _) as full_stack) ) ->\n check_var_annot loc annot >>?= fun () ->\n let () = check_dupable_comparable_ty t in\n opened_ticket_type loc t >>?= fun result ->\n let instr =\n {apply = (fun k -> IRead_ticket (loc, for_logging_only t, k))}\n in\n let stack = Item_t (result, full_stack) in\n typed ctxt loc instr stack\n | ( Prim (loc, I_SPLIT_TICKET, [], annot),\n Item_t\n ( (Ticket_t (t, _) as ticket_t),\n Item_t (Pair_t (Nat_t, Nat_t, _, _), rest) ) ) ->\n check_var_annot loc annot >>?= fun () ->\n let () = check_dupable_comparable_ty t in\n pair_t loc ticket_t ticket_t >>?= fun (Ty_ex_c pair_tickets_ty) ->\n option_t loc pair_tickets_ty >>?= fun res_ty ->\n let instr = {apply = (fun k -> ISplit_ticket (loc, k))} in\n let stack = Item_t (res_ty, rest) in\n typed ctxt loc instr stack\n | ( Prim (loc, I_JOIN_TICKETS, [], annot),\n Item_t\n ( Pair_t\n ( (Ticket_t (contents_ty_a, _) as ty_a),\n Ticket_t (contents_ty_b, _),\n _,\n _ ),\n rest ) ) ->\n check_var_annot loc annot >>?= fun () ->\n Gas_monad.run ctxt\n @@ ty_eq ~error_details:(Informative loc) contents_ty_a contents_ty_b\n >>?= fun (eq, ctxt) ->\n eq >>?= fun Eq ->\n option_t loc ty_a >>?= fun res_ty ->\n let instr = {apply = (fun k -> IJoin_tickets (loc, contents_ty_a, k))} in\n let stack = Item_t (res_ty, rest) in\n typed ctxt loc instr stack\n (* Timelocks *)\n | ( Prim (loc, I_OPEN_CHEST, [], _),\n Item_t (Chest_key_t, Item_t (Chest_t, Item_t (Nat_t, rest))) ) ->\n if legacy then\n let instr = {apply = (fun k -> IOpen_chest (loc, k))} in\n typed ctxt loc instr (Item_t (union_bytes_bool_t, rest))\n else tzfail (Deprecated_instruction I_OPEN_CHEST)\n (* Events *)\n | Prim (loc, I_EMIT, [], annot), Item_t (data, rest) ->\n check_packable ~legacy loc data >>?= fun () ->\n parse_entrypoint_annot_strict loc annot >>?= fun tag ->\n unparse_ty ~loc:() ctxt data >>?= fun (unparsed_ty, ctxt) ->\n Gas.consume ctxt (Script.strip_locations_cost unparsed_ty)\n >>?= fun ctxt ->\n let unparsed_ty = Micheline.strip_locations unparsed_ty in\n let instr =\n {apply = (fun k -> IEmit {loc; tag; ty = data; unparsed_ty; k})}\n in\n typed ctxt loc instr (Item_t (Operation_t, rest))\n | Prim (loc, I_EMIT, [ty_node], annot), Item_t (data, rest) ->\n parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty_node\n >>?= fun (Ex_ty ty, ctxt) ->\n check_item_ty ctxt ty data loc I_EMIT 1 2 >>?= fun (Eq, ctxt) ->\n parse_entrypoint_annot_strict loc annot >>?= fun tag ->\n Gas.consume ctxt (Script.strip_locations_cost ty_node) >>?= fun ctxt ->\n let unparsed_ty = Micheline.strip_locations ty_node in\n let instr =\n {apply = (fun k -> IEmit {loc; tag; ty = data; unparsed_ty; k})}\n in\n typed ctxt loc instr (Item_t (Operation_t, rest))\n (* Primitive parsing errors *)\n | ( Prim\n ( loc,\n (( I_DUP | I_SWAP | I_SOME | I_UNIT | I_PAIR | I_UNPAIR | I_CAR\n | I_CDR | I_CONS | I_CONCAT | I_SLICE | I_MEM | I_UPDATE | I_GET\n | I_EXEC | I_FAILWITH | I_SIZE | I_ADD | I_SUB | I_SUB_MUTEZ | I_MUL\n | I_EDIV | I_OR | I_AND | I_XOR | I_NOT | I_ABS | I_NEG | I_LSL\n | I_LSR | I_COMPARE | I_EQ | I_NEQ | I_LT | I_GT | I_LE | I_GE\n | I_TRANSFER_TOKENS | I_SET_DELEGATE | I_NOW | I_MIN_BLOCK_TIME\n | I_IMPLICIT_ACCOUNT | I_AMOUNT | I_BALANCE | I_LEVEL\n | I_CHECK_SIGNATURE | I_HASH_KEY | I_SOURCE | I_SENDER | I_BLAKE2B\n | I_SHA256 | I_SHA512 | I_ADDRESS | I_RENAME | I_PACK | I_ISNAT\n | I_INT | I_SELF | I_CHAIN_ID | I_NEVER | I_VOTING_POWER\n | I_TOTAL_VOTING_POWER | I_KECCAK | I_SHA3 | I_PAIRING_CHECK\n | I_TICKET | I_READ_TICKET | I_SPLIT_TICKET | I_JOIN_TICKETS\n | I_OPEN_CHEST ) as name),\n (_ :: _ as l),\n _ ),\n _ ) ->\n tzfail (Invalid_arity (loc, name, 0, List.length l))\n | ( Prim\n ( loc,\n (( I_NONE | I_LEFT | I_RIGHT | I_NIL | I_MAP | I_ITER | I_EMPTY_SET\n | I_LOOP | I_LOOP_LEFT | I_CONTRACT | I_CAST | I_UNPACK\n | I_CREATE_CONTRACT | I_EMIT ) as name),\n (([] | _ :: _ :: _) as l),\n _ ),\n _ ) ->\n tzfail (Invalid_arity (loc, name, 1, List.length l))\n | ( Prim\n ( loc,\n (( I_PUSH | I_VIEW | I_IF_NONE | I_IF_LEFT | I_IF_CONS | I_EMPTY_MAP\n | I_EMPTY_BIG_MAP | I_IF ) as name),\n (([] | [_] | _ :: _ :: _ :: _) as l),\n _ ),\n _ ) ->\n tzfail (Invalid_arity (loc, name, 2, List.length l))\n | ( Prim (loc, I_LAMBDA, (([] | [_] | [_; _] | _ :: _ :: _ :: _ :: _) as l), _),\n _ ) ->\n tzfail (Invalid_arity (loc, I_LAMBDA, 3, List.length l))\n (* Stack errors *)\n | ( Prim\n ( loc,\n (( I_ADD | I_SUB | I_SUB_MUTEZ | I_MUL | I_EDIV | I_AND | I_OR | I_XOR\n | I_LSL | I_LSR | I_CONCAT | I_PAIRING_CHECK ) as name),\n [],\n _ ),\n Item_t (ta, Item_t (tb, _)) ) ->\n let ta = serialize_ty_for_error ta in\n let tb = serialize_ty_for_error tb in\n tzfail (Undefined_binop (loc, name, ta, tb))\n | ( Prim\n ( loc,\n (( I_NEG | I_ABS | I_NOT | I_SIZE | I_EQ | I_NEQ | I_LT | I_GT | I_LE\n | I_GE\n (* CONCAT is both unary and binary; this case can only be triggered\n on a singleton stack *)\n | I_CONCAT ) as name),\n [],\n _ ),\n Item_t (t, _) ) ->\n let t = serialize_ty_for_error t in\n tzfail (Undefined_unop (loc, name, t))\n | Prim (loc, ((I_UPDATE | I_SLICE | I_OPEN_CHEST) as name), [], _), stack ->\n Lwt.return\n (let stack = serialize_stack_for_error ctxt stack in\n error (Bad_stack (loc, name, 3, stack)))\n | Prim (loc, I_CREATE_CONTRACT, _, _), stack ->\n let stack = serialize_stack_for_error ctxt stack in\n tzfail (Bad_stack (loc, I_CREATE_CONTRACT, 7, stack))\n | Prim (loc, I_TRANSFER_TOKENS, [], _), stack ->\n Lwt.return\n (let stack = serialize_stack_for_error ctxt stack in\n error (Bad_stack (loc, I_TRANSFER_TOKENS, 4, stack)))\n | ( Prim\n ( loc,\n (( I_DROP | I_DUP | I_CAR | I_CDR | I_UNPAIR | I_SOME | I_BLAKE2B\n | I_SHA256 | I_SHA512 | I_DIP | I_IF_NONE | I_LEFT | I_RIGHT\n | I_IF_LEFT | I_IF | I_LOOP | I_IF_CONS | I_IMPLICIT_ACCOUNT | I_NEG\n | I_ABS | I_INT | I_NOT | I_HASH_KEY | I_EQ | I_NEQ | I_LT | I_GT\n | I_LE | I_GE | I_SIZE | I_FAILWITH | I_RENAME | I_PACK | I_ISNAT\n | I_ADDRESS | I_SET_DELEGATE | I_CAST | I_MAP | I_ITER | I_LOOP_LEFT\n | I_UNPACK | I_CONTRACT | I_NEVER | I_KECCAK | I_SHA3 | I_READ_TICKET\n | I_JOIN_TICKETS ) as name),\n _,\n _ ),\n stack ) ->\n Lwt.return\n (let stack = serialize_stack_for_error ctxt stack in\n error (Bad_stack (loc, name, 1, stack)))\n | ( Prim\n ( loc,\n (( I_SWAP | I_PAIR | I_CONS | I_GET | I_MEM | I_EXEC\n | I_CHECK_SIGNATURE | I_ADD | I_SUB | I_SUB_MUTEZ | I_MUL | I_EDIV\n | I_AND | I_OR | I_XOR | I_LSL | I_LSR | I_COMPARE | I_PAIRING_CHECK\n | I_TICKET | I_SPLIT_TICKET ) as name),\n _,\n _ ),\n stack ) ->\n Lwt.return\n (let stack = serialize_stack_for_error ctxt stack in\n error (Bad_stack (loc, name, 2, stack)))\n (* Generic parsing errors *)\n | expr, _ ->\n tzfail\n @@ unexpected\n expr\n [Seq_kind]\n Instr_namespace\n [\n I_ABS;\n I_ADD;\n I_AMOUNT;\n I_AND;\n I_BALANCE;\n I_BLAKE2B;\n I_CAR;\n I_CDR;\n I_CHECK_SIGNATURE;\n I_COMPARE;\n I_CONCAT;\n I_CONS;\n I_CREATE_CONTRACT;\n I_DIG;\n I_DIP;\n I_DROP;\n I_DUG;\n I_DUP;\n I_EDIV;\n I_EMPTY_BIG_MAP;\n I_EMPTY_MAP;\n I_EMPTY_SET;\n I_EQ;\n I_EXEC;\n I_FAILWITH;\n I_GE;\n I_GET;\n I_GET_AND_UPDATE;\n I_GT;\n I_HASH_KEY;\n I_IF;\n I_IF_CONS;\n I_IF_LEFT;\n I_IF_NONE;\n I_IMPLICIT_ACCOUNT;\n I_INT;\n I_ITER;\n I_JOIN_TICKETS;\n I_KECCAK;\n I_LAMBDA;\n I_LE;\n I_LEFT;\n I_LEVEL;\n I_LOOP;\n I_LSL;\n I_LSR;\n I_LT;\n I_MAP;\n I_MEM;\n I_MIN_BLOCK_TIME;\n I_MUL;\n I_NEG;\n I_NEQ;\n I_NEVER;\n I_NIL;\n I_NONE;\n I_NOT;\n I_NOW;\n I_OPEN_CHEST;\n I_OR;\n I_PAIR;\n I_PAIRING_CHECK;\n I_PUSH;\n I_READ_TICKET;\n I_RIGHT;\n I_SAPLING_EMPTY_STATE;\n I_SAPLING_VERIFY_UPDATE;\n I_SELF;\n I_SELF_ADDRESS;\n I_SENDER;\n I_SHA256;\n I_SHA3;\n I_SHA512;\n I_SIZE;\n I_SOME;\n I_SOURCE;\n I_SPLIT_TICKET;\n I_SUB;\n I_SUB_MUTEZ;\n I_SWAP;\n I_TICKET;\n I_TOTAL_VOTING_POWER;\n I_TRANSFER_TOKENS;\n I_UNIT;\n I_UNPAIR;\n I_UPDATE;\n I_VIEW;\n I_VOTING_POWER;\n I_XOR;\n ]\n\nand parse_contract_data :\n type arg argc.\n stack_depth:int ->\n context ->\n Script.location ->\n (arg, argc) ty ->\n Destination.t ->\n entrypoint:Entrypoint.t ->\n (context * arg typed_contract) tzresult Lwt.t =\n fun ~stack_depth ctxt loc arg destination ~entrypoint ->\n let error_details = Informative loc in\n parse_contract\n ~stack_depth:(stack_depth + 1)\n ctxt\n ~error_details\n loc\n arg\n destination\n ~entrypoint\n >>=? fun (ctxt, res) -> Lwt.return (res >|? fun res -> (ctxt, res))\n\n(* [parse_contract] is used both to:\n - parse contract data by [parse_data] ([parse_contract_data])\n - to execute the [CONTRACT] instruction ([parse_contract_for_script]).\n\n The return type resembles the [Gas_monad]:\n - the outer [tzresult] is for gas exhaustion and internal errors\n - the inner [result] is for other legitimate cases of failure.\n\n The inner [result] is turned into an [option] by [parse_contract_for_script].\n Both [tzresult] are merged by [parse_contract_data].\n*)\nand parse_contract :\n type arg argc err.\n stack_depth:int ->\n context ->\n error_details:(location, err) error_details ->\n Script.location ->\n (arg, argc) ty ->\n Destination.t ->\n entrypoint:Entrypoint.t ->\n (context * (arg typed_contract, err) result) tzresult Lwt.t =\n fun ~stack_depth ctxt ~error_details loc arg destination ~entrypoint ->\n let error ctxt f_err : context * (_, err) result =\n ( ctxt,\n Error\n (match error_details with\n | Fast -> (Inconsistent_types_fast : err)\n | Informative loc -> trace_of_error @@ f_err loc) )\n in\n Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt ->\n match destination with\n | Contract contract -> (\n match contract with\n | Implicit destination ->\n Lwt.return\n @@\n if Entrypoint.is_default entrypoint then\n (* An implicit account on the \"default\" entrypoint always exists and has type unit\n or (ticket cty). *)\n let typecheck =\n let open Gas_monad.Syntax in\n let* () = Gas_monad.consume_gas Typecheck_costs.merge_cycle in\n match arg with\n | Unit_t ->\n return (Typed_implicit destination : arg typed_contract)\n | Ticket_t _ as ticket_ty ->\n return (Typed_implicit_with_ticket {ticket_ty; destination})\n | _ ->\n Gas_monad.of_result\n @@ Error\n (match error_details with\n | Fast -> (Inconsistent_types_fast : err)\n | Informative loc ->\n trace_of_error @@ default_ty_eq_error loc arg unit_t)\n in\n Gas_monad.run ctxt typecheck >|? fun (v, ctxt) -> (ctxt, v)\n else\n (* An implicit account on any other entrypoint is not a valid contract. *)\n ok @@ error ctxt (fun _loc -> No_such_entrypoint entrypoint)\n | Originated contract_hash ->\n trace\n (Invalid_contract (loc, contract))\n ( Contract.get_script_code ctxt contract_hash\n >>=? fun (ctxt, code) ->\n Lwt.return\n (match code with\n | None ->\n ok\n (error ctxt (fun loc -> Invalid_contract (loc, contract)))\n | Some code ->\n Script.force_decode_in_context\n ~consume_deserialization_gas:When_needed\n ctxt\n code\n >>? fun (code, ctxt) ->\n (* can only fail because of gas *)\n parse_toplevel ctxt ~legacy:true code\n >>? fun ({arg_type; _}, ctxt) ->\n parse_parameter_ty_and_entrypoints\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy:true\n arg_type\n >>? fun ( Ex_parameter_ty_and_entrypoints\n {arg_type = targ; entrypoints},\n ctxt ) ->\n Gas_monad.run ctxt\n @@ find_entrypoint_for_type\n ~error_details\n ~full:targ\n ~expected:arg\n entrypoints\n entrypoint\n >|? fun (entrypoint_arg, ctxt) ->\n ( ctxt,\n entrypoint_arg >|? fun (entrypoint, arg_ty) ->\n Typed_originated {arg_ty; contract_hash; entrypoint} )) ))\n | Tx_rollup tx_rollup ->\n Tx_rollup_state.assert_exist ctxt tx_rollup >|=? fun ctxt ->\n if Entrypoint.(is_deposit entrypoint) then\n (* /!\\ This pattern matching needs to remain in sync with\n [parse_tx_rollup_deposit_parameters]. *)\n match arg with\n | Pair_t (Ticket_t (_, _), Tx_rollup_l2_address_t, _, _) ->\n ( ctxt,\n ok\n @@ (Typed_tx_rollup {arg_ty = arg; tx_rollup}\n : arg typed_contract) )\n | _ ->\n error ctxt (fun loc ->\n Tx_rollup_bad_deposit_parameter (loc, serialize_ty_for_error arg))\n else error ctxt (fun _loc -> No_such_entrypoint entrypoint)\n | Zk_rollup zk_rollup ->\n Zk_rollup.assert_exist ctxt zk_rollup >|=? fun ctxt ->\n if Entrypoint.(is_deposit entrypoint) then\n match arg with\n | Pair_t (Ticket_t (_, _), Bytes_t, _, _) ->\n ( ctxt,\n ok\n @@ (Typed_zk_rollup {arg_ty = arg; zk_rollup}\n : arg typed_contract) )\n | _ ->\n error ctxt (fun loc ->\n Zk_rollup_bad_deposit_parameter (loc, serialize_ty_for_error arg))\n else error ctxt (fun _loc -> No_such_entrypoint entrypoint)\n | Sc_rollup sc_rollup ->\n Sc_rollup.parameters_type ctxt sc_rollup\n >>=? fun (parameters_type, ctxt) ->\n Lwt.return\n (match parameters_type with\n | None ->\n ok\n (error ctxt (fun _loc ->\n Sc_rollup.Errors.Sc_rollup_does_not_exist sc_rollup))\n | Some parameters_type ->\n Script.force_decode_in_context\n ~consume_deserialization_gas:When_needed\n ctxt\n parameters_type\n >>? fun (parameters_type, ctxt) ->\n parse_parameter_ty_and_entrypoints\n ctxt\n ~stack_depth:(stack_depth + 1)\n ~legacy:true\n (root parameters_type)\n >>? fun ( Ex_parameter_ty_and_entrypoints\n {arg_type = full; entrypoints},\n ctxt ) ->\n Gas_monad.run ctxt\n @@ find_entrypoint_for_type\n ~error_details\n ~full\n ~expected:arg\n entrypoints\n entrypoint\n >|? fun (entrypoint_arg, ctxt) ->\n ( ctxt,\n entrypoint_arg >|? fun (entrypoint, arg_ty) ->\n Typed_sc_rollup {arg_ty; sc_rollup; entrypoint} ))\n\n(* Same as [parse_contract], but does not fail when the contact is missing or\n if the expected type doesn't match the actual one. In that case None is\n returned and some overapproximation of the typechecking gas is consumed.\n This can still fail on gas exhaustion. *)\nlet parse_contract_for_script :\n type arg argc.\n context ->\n Script.location ->\n (arg, argc) ty ->\n Destination.t ->\n entrypoint:Entrypoint.t ->\n (context * arg typed_contract option) tzresult Lwt.t =\n fun ctxt loc arg destination ~entrypoint ->\n parse_contract\n ~stack_depth:0\n ctxt\n ~error_details:Fast\n loc\n arg\n destination\n ~entrypoint\n >|=? fun (ctxt, res) ->\n ( ctxt,\n match res with Ok res -> Some res | Error Inconsistent_types_fast -> None )\n\nlet view_size view =\n let open Script_typed_ir_size in\n node_size view.view_code ++ node_size view.input_ty\n ++ node_size view.output_ty\n\nlet code_size ctxt code views =\n let open Script_typed_ir_size in\n let views_size = Script_map.fold (fun _ v s -> view_size v ++ s) views zero in\n (* The size of the storage_type and the arg_type is counted by\n [lambda_size]. *)\n let ir_size = lambda_size code in\n let nodes, code_size = views_size ++ ir_size in\n (* We consume gas after the fact in order to not have to instrument\n [node_size] (for efficiency).\n This is safe, as we already pay gas proportional to [views_size] and\n [ir_size] during their typechecking. *)\n Gas.consume ctxt (Script_typed_ir_size_costs.nodes_cost ~nodes)\n >|? fun ctxt -> (code_size, ctxt)\n\nlet parse_code :\n unparse_code_rec:Script_ir_unparser.unparse_code_rec ->\n elab_conf:elab_conf ->\n context ->\n code:lazy_expr ->\n (ex_code * context) tzresult Lwt.t =\n fun ~unparse_code_rec ~elab_conf ctxt ~code ->\n Script.force_decode_in_context\n ~consume_deserialization_gas:When_needed\n ctxt\n code\n >>?= fun (code, ctxt) ->\n let legacy = elab_conf.legacy in\n Global_constants_storage.expand ctxt code >>=? fun (ctxt, code) ->\n parse_toplevel ctxt ~legacy code\n >>?= fun ({arg_type; storage_type; code_field; views}, ctxt) ->\n let arg_type_loc = location arg_type in\n record_trace\n (Ill_formed_type (Some \"parameter\", code, arg_type_loc))\n (parse_parameter_ty_and_entrypoints ctxt ~stack_depth:0 ~legacy arg_type)\n >>?= fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) ->\n let storage_type_loc = location storage_type in\n record_trace\n (Ill_formed_type (Some \"storage\", code, storage_type_loc))\n (parse_storage_ty ctxt ~stack_depth:0 ~legacy storage_type)\n >>?= fun (Ex_ty storage_type, ctxt) ->\n pair_t storage_type_loc arg_type storage_type\n >>?= fun (Ty_ex_c arg_type_full) ->\n pair_t storage_type_loc list_operation_t storage_type\n >>?= fun (Ty_ex_c ret_type_full) ->\n trace\n (Ill_typed_contract (code, []))\n (parse_kdescr\n ~unparse_code_rec\n Tc_context.(toplevel ~storage_type ~param_type:arg_type ~entrypoints)\n ~elab_conf\n ctxt\n ~stack_depth:0\n arg_type_full\n ret_type_full\n code_field)\n >>=? fun (kdescr, ctxt) ->\n let code = Lam (kdescr, code_field) in\n Lwt.return\n ( code_size ctxt code views >>? fun (code_size, ctxt) ->\n ok\n ( Ex_code\n (Code {code; arg_type; storage_type; views; entrypoints; code_size}),\n ctxt ) )\n\nlet parse_storage :\n unparse_code_rec:Script_ir_unparser.unparse_code_rec ->\n elab_conf:elab_conf ->\n context ->\n allow_forged:bool ->\n ('storage, _) ty ->\n storage:lazy_expr ->\n ('storage * context) tzresult Lwt.t =\n fun ~unparse_code_rec ~elab_conf ctxt ~allow_forged storage_type ~storage ->\n Script.force_decode_in_context\n ~consume_deserialization_gas:When_needed\n ctxt\n storage\n >>?= fun (storage, ctxt) ->\n trace_eval\n (fun () ->\n let storage_type = serialize_ty_for_error storage_type in\n Ill_typed_data (None, storage, storage_type))\n (parse_data\n ~unparse_code_rec\n ~elab_conf\n ~stack_depth:0\n ctxt\n ~allow_forged\n storage_type\n (root storage))\n\nlet parse_script :\n unparse_code_rec:Script_ir_unparser.unparse_code_rec ->\n elab_conf:elab_conf ->\n context ->\n allow_forged_in_storage:bool ->\n Script.t ->\n (ex_script * context) tzresult Lwt.t =\n fun ~unparse_code_rec ~elab_conf ctxt ~allow_forged_in_storage {code; storage} ->\n parse_code ~unparse_code_rec ~elab_conf ctxt ~code\n >>=? fun ( Ex_code\n (Code\n {code; arg_type; storage_type; views; entrypoints; code_size}),\n ctxt ) ->\n parse_storage\n ~unparse_code_rec\n ~elab_conf\n ctxt\n ~allow_forged:allow_forged_in_storage\n storage_type\n ~storage\n >|=? fun (storage, ctxt) ->\n ( Ex_script\n (Script\n {code_size; code; arg_type; storage; storage_type; views; entrypoints}),\n ctxt )\n\ntype typechecked_code_internal =\n | Typechecked_code_internal : {\n toplevel : toplevel;\n arg_type : ('arg, _) ty;\n storage_type : ('storage, _) ty;\n entrypoints : 'arg entrypoints;\n typed_views : 'storage typed_view_map;\n type_map : type_map;\n }\n -> typechecked_code_internal\n\nlet typecheck_code :\n unparse_code_rec:Script_ir_unparser.unparse_code_rec ->\n legacy:bool ->\n show_types:bool ->\n context ->\n Script.expr ->\n (typechecked_code_internal * context) tzresult Lwt.t =\n fun ~unparse_code_rec ~legacy ~show_types ctxt code ->\n (* Constants need to be expanded or [parse_toplevel] may fail. *)\n Global_constants_storage.expand ctxt code >>=? fun (ctxt, code) ->\n parse_toplevel ctxt ~legacy code >>?= fun (toplevel, ctxt) ->\n let {arg_type; storage_type; code_field; views} = toplevel in\n let type_map = ref [] in\n let arg_type_loc = location arg_type in\n record_trace\n (Ill_formed_type (Some \"parameter\", code, arg_type_loc))\n (parse_parameter_ty_and_entrypoints ctxt ~stack_depth:0 ~legacy arg_type)\n >>?= fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) ->\n let storage_type_loc = location storage_type in\n record_trace\n (Ill_formed_type (Some \"storage\", code, storage_type_loc))\n (parse_storage_ty ctxt ~stack_depth:0 ~legacy storage_type)\n >>?= fun (ex_storage_type, ctxt) ->\n let (Ex_ty storage_type) = ex_storage_type in\n pair_t storage_type_loc arg_type storage_type\n >>?= fun (Ty_ex_c arg_type_full) ->\n pair_t storage_type_loc list_operation_t storage_type\n >>?= fun (Ty_ex_c ret_type_full) ->\n let type_logger loc ~stack_ty_before ~stack_ty_after =\n type_map := (loc, (stack_ty_before, stack_ty_after)) :: !type_map\n in\n let type_logger = if show_types then Some type_logger else None in\n let elab_conf = Script_ir_translator_config.make ~legacy ?type_logger () in\n let result =\n parse_kdescr\n ~unparse_code_rec\n (Tc_context.toplevel ~storage_type ~param_type:arg_type ~entrypoints)\n ctxt\n ~elab_conf\n ~stack_depth:0\n arg_type_full\n ret_type_full\n code_field\n in\n trace (Ill_typed_contract (code, !type_map)) result\n >>=? fun ((_ : (_, _, _, _) kdescr), ctxt) ->\n let views_result =\n parse_views ~unparse_code_rec ctxt ~elab_conf storage_type views\n in\n trace (Ill_typed_contract (code, !type_map)) views_result\n >|=? fun (typed_views, ctxt) ->\n ( Typechecked_code_internal\n {\n toplevel;\n arg_type;\n storage_type;\n entrypoints;\n typed_views;\n type_map = !type_map;\n },\n ctxt )\n\n(* Uncarbonated because used only in RPCs *)\nlet list_entrypoints_uncarbonated (type full fullc) (full : (full, fullc) ty)\n (entrypoints : full entrypoints) =\n let merge path (type t tc) (ty : (t, tc) ty)\n (entrypoints : t entrypoints_node) reachable ((unreachables, all) as acc)\n =\n match entrypoints.at_node with\n | None ->\n ( (if reachable then acc\n else\n match ty with\n | Union_t _ -> acc\n | _ -> (List.rev path :: unreachables, all)),\n reachable )\n | Some {name; original_type_expr} ->\n ( (if Entrypoint.Map.mem name all then\n (List.rev path :: unreachables, all)\n else\n ( unreachables,\n Entrypoint.Map.add name (Ex_ty ty, original_type_expr) all )),\n true )\n in\n let rec fold_tree :\n type t tc.\n (t, tc) ty ->\n t entrypoints_node ->\n prim list ->\n bool ->\n prim list list * (ex_ty * Script.node) Entrypoint.Map.t ->\n prim list list * (ex_ty * Script.node) Entrypoint.Map.t =\n fun t entrypoints path reachable acc ->\n match (t, entrypoints) with\n | Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _} ->\n let acc, l_reachable = merge (D_Left :: path) tl left reachable acc in\n let acc, r_reachable = merge (D_Right :: path) tr right reachable acc in\n let acc = fold_tree tl left (D_Left :: path) l_reachable acc in\n fold_tree tr right (D_Right :: path) r_reachable acc\n | _ -> acc\n in\n let init, reachable =\n match entrypoints.root.at_node with\n | None -> (Entrypoint.Map.empty, false)\n | Some {name; original_type_expr} ->\n (Entrypoint.Map.singleton name (Ex_ty full, original_type_expr), true)\n in\n fold_tree full entrypoints.root [] reachable ([], init)\n\ninclude Data_unparser (struct\n let opened_ticket_type = opened_ticket_type\n\n let parse_packable_ty = parse_packable_ty\n\n let parse_data = parse_data\nend)\n\nlet unparse_code_rec : unparse_code_rec =\n fun ctxt ~stack_depth mode node ->\n unparse_code ctxt ~stack_depth mode node >>=? fun (code, ctxt) ->\n return (Micheline.root code, ctxt)\n\nlet parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage\n mode ~normalize_types {code; storage} =\n Script.force_decode_in_context\n ~consume_deserialization_gas:When_needed\n ctxt\n code\n >>?= fun (code, ctxt) ->\n typecheck_code ~unparse_code_rec ~legacy ~show_types:false ctxt code\n >>=? fun ( Typechecked_code_internal\n {\n toplevel =\n {\n code_field;\n arg_type = original_arg_type_expr;\n storage_type = original_storage_type_expr;\n views;\n };\n arg_type;\n storage_type;\n entrypoints;\n typed_views;\n type_map = _;\n },\n ctxt ) ->\n parse_storage\n ~unparse_code_rec\n ~elab_conf:(Script_ir_translator_config.make ~legacy ())\n ctxt\n ~allow_forged:allow_forged_in_storage\n storage_type\n ~storage\n >>=? fun (storage, ctxt) ->\n unparse_code ctxt ~stack_depth:0 mode code_field >>=? fun (code, ctxt) ->\n unparse_data ctxt ~stack_depth:0 mode storage_type storage\n >>=? fun (storage, ctxt) ->\n let loc = Micheline.dummy_location in\n (if normalize_types then\n unparse_parameter_ty ~loc ctxt arg_type ~entrypoints\n >>?= fun (arg_type, ctxt) ->\n unparse_ty ~loc ctxt storage_type >>?= fun (storage_type, ctxt) ->\n Script_map.map_es_in_context\n (fun ctxt\n _name\n (Typed_view {input_ty; output_ty; kinstr = _; original_code_expr}) ->\n Lwt.return\n ( unparse_ty ~loc ctxt input_ty >>? fun (input_ty, ctxt) ->\n unparse_ty ~loc ctxt output_ty >|? fun (output_ty, ctxt) ->\n ({input_ty; output_ty; view_code = original_code_expr}, ctxt) ))\n ctxt\n typed_views\n >|=? fun (views, ctxt) -> (arg_type, storage_type, views, ctxt)\n else return (original_arg_type_expr, original_storage_type_expr, views, ctxt))\n >>=? fun (arg_type, storage_type, views, ctxt) ->\n Script_map.map_es_in_context\n (fun ctxt _name {input_ty; output_ty; view_code} ->\n unparse_code ctxt ~stack_depth:0 mode view_code\n >|=? fun (view_code, ctxt) ->\n let view_code = Micheline.root view_code in\n ({input_ty; output_ty; view_code}, ctxt))\n ctxt\n views\n >>=? fun (views, ctxt) ->\n let open Micheline in\n let unparse_view_unaccounted name {input_ty; output_ty; view_code} views =\n Prim\n ( loc,\n K_view,\n [\n String (loc, Script_string.to_string name);\n input_ty;\n output_ty;\n view_code;\n ],\n [] )\n :: views\n in\n let views = Script_map.fold unparse_view_unaccounted views [] |> List.rev in\n let code =\n Seq\n ( loc,\n [\n Prim (loc, K_parameter, [arg_type], []);\n Prim (loc, K_storage, [storage_type], []);\n Prim (loc, K_code, [Micheline.root code], []);\n ]\n @ views )\n in\n return\n ( {code = lazy_expr (strip_locations code); storage = lazy_expr storage},\n ctxt )\n\nlet pack_data_with_mode ctxt ty data ~mode =\n unparse_data ~stack_depth:0 ctxt mode ty data >|=? fun (unparsed, ctxt) ->\n pack_node unparsed ctxt\n\nlet hash_data ctxt ty data =\n pack_data_with_mode ctxt ty data ~mode:Optimized_legacy\n >>=? fun (bytes, ctxt) -> Lwt.return @@ hash_bytes ctxt bytes\n\nlet pack_data ctxt ty data =\n pack_data_with_mode ctxt ty data ~mode:Optimized_legacy\n\n(* ---------------- Lazy storage---------------------------------------------*)\n\ntype lazy_storage_ids = Lazy_storage.IdSet.t\n\nlet no_lazy_storage_id = Lazy_storage.IdSet.empty\n\nlet diff_of_big_map ctxt mode ~temporary ~ids_to_copy\n (Big_map {id; key_type; value_type; diff}) =\n (match id with\n | Some id ->\n if Lazy_storage.IdSet.mem Big_map id ids_to_copy then\n Big_map.fresh ~temporary ctxt >|=? fun (ctxt, duplicate) ->\n (ctxt, Lazy_storage.Copy {src = id}, duplicate)\n else\n (* The first occurrence encountered of a big_map reuses the\n ID. This way, the payer is only charged for the diff.\n For this to work, this diff has to be put at the end of\n the global diff, otherwise the duplicates will use the\n updated version as a base. This is true because we add\n this diff first in the accumulator of\n `extract_lazy_storage_updates`, and this accumulator is not\n reversed. *)\n return (ctxt, Lazy_storage.Existing, id)\n | None ->\n Big_map.fresh ~temporary ctxt >>=? fun (ctxt, id) ->\n Lwt.return\n (let kt = unparse_comparable_ty_uncarbonated ~loc:() key_type in\n Gas.consume ctxt (Script.strip_locations_cost kt) >>? fun ctxt ->\n unparse_ty ~loc:() ctxt value_type >>? fun (kv, ctxt) ->\n Gas.consume ctxt (Script.strip_locations_cost kv) >|? fun ctxt ->\n let key_type = Micheline.strip_locations kt in\n let value_type = Micheline.strip_locations kv in\n (ctxt, Lazy_storage.(Alloc Big_map.{key_type; value_type}), id)))\n >>=? fun (ctxt, init, id) ->\n let pairs =\n Big_map_overlay.fold\n (fun key_hash (key, value) acc -> (key_hash, key, value) :: acc)\n diff.map\n []\n in\n List.fold_left_es\n (fun (acc, ctxt) (key_hash, key, value) ->\n Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt ->\n unparse_comparable_data ctxt mode key_type key >>=? fun (key, ctxt) ->\n (match value with\n | None -> return (None, ctxt)\n | Some x ->\n unparse_data ~stack_depth:0 ctxt mode value_type x\n >|=? fun (node, ctxt) -> (Some node, ctxt))\n >|=? fun (value, ctxt) ->\n let diff_item = Big_map.{key; key_hash; value} in\n (diff_item :: acc, ctxt))\n ([], ctxt)\n (List.rev pairs)\n >|=? fun (updates, ctxt) -> (Lazy_storage.Update {init; updates}, id, ctxt)\n\nlet diff_of_sapling_state ctxt ~temporary ~ids_to_copy\n ({id; diff; memo_size} : Sapling.state) =\n (match id with\n | Some id ->\n if Lazy_storage.IdSet.mem Sapling_state id ids_to_copy then\n Sapling.fresh ~temporary ctxt >|=? fun (ctxt, duplicate) ->\n (ctxt, Lazy_storage.Copy {src = id}, duplicate)\n else return (ctxt, Lazy_storage.Existing, id)\n | None ->\n Sapling.fresh ~temporary ctxt >|=? fun (ctxt, id) ->\n (ctxt, Lazy_storage.Alloc Sapling.{memo_size}, id))\n >|=? fun (ctxt, init, id) ->\n (Lazy_storage.Update {init; updates = diff}, id, ctxt)\n\n(**\n Witness flag for whether a type can be populated by a value containing a\n lazy storage.\n [False_f] must be used only when a value of the type cannot contain a lazy\n storage.\n\n This flag is built in [has_lazy_storage] and used only in\n [extract_lazy_storage_updates] and [collect_lazy_storage].\n\n This flag is necessary to avoid these two functions to have a quadratic\n complexity in the size of the type.\n\n Add new lazy storage kinds here.\n\n Please keep the usage of this GADT local.\n*)\n\ntype 'ty has_lazy_storage =\n | Big_map_f : ('a, 'b) big_map has_lazy_storage\n | Sapling_state_f : Sapling.state has_lazy_storage\n | False_f : _ has_lazy_storage\n | Pair_f :\n 'a has_lazy_storage * 'b has_lazy_storage\n -> ('a, 'b) pair has_lazy_storage\n | Union_f :\n 'a has_lazy_storage * 'b has_lazy_storage\n -> ('a, 'b) union has_lazy_storage\n | Option_f : 'a has_lazy_storage -> 'a option has_lazy_storage\n | List_f : 'a has_lazy_storage -> 'a Script_list.t has_lazy_storage\n | Map_f : 'v has_lazy_storage -> (_, 'v) map has_lazy_storage\n\n(**\n This function is called only on storage and parameter types of contracts,\n once per typechecked contract. It has a complexity linear in the size of\n the types, which happen to be literally written types, so the gas for them\n has already been paid.\n*)\nlet rec has_lazy_storage : type t tc. (t, tc) ty -> t has_lazy_storage =\n fun ty ->\n let aux1 cons t =\n match has_lazy_storage t with False_f -> False_f | h -> cons h\n in\n let aux2 cons t1 t2 =\n match (has_lazy_storage t1, has_lazy_storage t2) with\n | False_f, False_f -> False_f\n | h1, h2 -> cons h1 h2\n in\n match ty with\n | Big_map_t (_, _, _) -> Big_map_f\n | Sapling_state_t _ -> Sapling_state_f\n | Unit_t -> False_f\n | Int_t -> False_f\n | Nat_t -> False_f\n | Signature_t -> False_f\n | String_t -> False_f\n | Bytes_t -> False_f\n | Mutez_t -> False_f\n | Key_hash_t -> False_f\n | Key_t -> False_f\n | Timestamp_t -> False_f\n | Address_t -> False_f\n | Tx_rollup_l2_address_t -> False_f\n | Bool_t -> False_f\n | Lambda_t (_, _, _) -> False_f\n | Set_t (_, _) -> False_f\n | Contract_t (_, _) -> False_f\n | Operation_t -> False_f\n | Chain_id_t -> False_f\n | Never_t -> False_f\n | Bls12_381_g1_t -> False_f\n | Bls12_381_g2_t -> False_f\n | Bls12_381_fr_t -> False_f\n | Sapling_transaction_t _ -> False_f\n | Sapling_transaction_deprecated_t _ -> False_f\n | Ticket_t _ -> False_f\n | Chest_key_t -> False_f\n | Chest_t -> False_f\n | Pair_t (l, r, _, _) -> aux2 (fun l r -> Pair_f (l, r)) l r\n | Union_t (l, r, _, _) -> aux2 (fun l r -> Union_f (l, r)) l r\n | Option_t (t, _, _) -> aux1 (fun h -> Option_f h) t\n | List_t (t, _) -> aux1 (fun h -> List_f h) t\n | Map_t (_, t, _) -> aux1 (fun h -> Map_f h) t\n\n(**\n Transforms a value potentially containing lazy storage in an intermediary\n state to a value containing lazy storage only represented by identifiers.\n\n Returns the updated value, the updated set of ids to copy, and the lazy\n storage diff to show on the receipt and apply on the storage.\n\n*)\nlet extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x =\n let rec aux :\n type a ac.\n context ->\n unparsing_mode ->\n temporary:bool ->\n Lazy_storage.IdSet.t ->\n Lazy_storage.diffs ->\n (a, ac) ty ->\n a ->\n has_lazy_storage:a has_lazy_storage ->\n (context * a * Lazy_storage.IdSet.t * Lazy_storage.diffs) tzresult Lwt.t =\n fun ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage ->\n Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt ->\n match (has_lazy_storage, ty, x) with\n | False_f, _, _ -> return (ctxt, x, ids_to_copy, acc)\n | Big_map_f, Big_map_t (_, _, _), map ->\n diff_of_big_map ctxt mode ~temporary ~ids_to_copy map\n >|=? fun (diff, id, ctxt) ->\n let map =\n let (Big_map map) = map in\n Big_map\n {\n map with\n diff = {map = Big_map_overlay.empty; size = 0};\n id = Some id;\n }\n in\n let diff = Lazy_storage.make Big_map id diff in\n let ids_to_copy = Lazy_storage.IdSet.add Big_map id ids_to_copy in\n (ctxt, map, ids_to_copy, diff :: acc)\n | Sapling_state_f, Sapling_state_t _, sapling_state ->\n diff_of_sapling_state ctxt ~temporary ~ids_to_copy sapling_state\n >|=? fun (diff, id, ctxt) ->\n let sapling_state =\n Sapling.empty_state ~id ~memo_size:sapling_state.memo_size ()\n in\n let diff = Lazy_storage.make Sapling_state id diff in\n let ids_to_copy = Lazy_storage.IdSet.add Sapling_state id ids_to_copy in\n (ctxt, sapling_state, ids_to_copy, diff :: acc)\n | Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (xl, xr) ->\n aux ctxt mode ~temporary ids_to_copy acc tyl xl ~has_lazy_storage:hl\n >>=? fun (ctxt, xl, ids_to_copy, acc) ->\n aux ctxt mode ~temporary ids_to_copy acc tyr xr ~has_lazy_storage:hr\n >|=? fun (ctxt, xr, ids_to_copy, acc) ->\n (ctxt, (xl, xr), ids_to_copy, acc)\n | Union_f (has_lazy_storage, _), Union_t (ty, _, _, _), L x ->\n aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage\n >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, L x, ids_to_copy, acc)\n | Union_f (_, has_lazy_storage), Union_t (_, ty, _, _), R x ->\n aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage\n >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, R x, ids_to_copy, acc)\n | Option_f has_lazy_storage, Option_t (ty, _, _), Some x ->\n aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage\n >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, Some x, ids_to_copy, acc)\n | List_f has_lazy_storage, List_t (ty, _), l ->\n List.fold_left_es\n (fun (ctxt, l, ids_to_copy, acc) x ->\n aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage\n >|=? fun (ctxt, x, ids_to_copy, acc) ->\n (ctxt, Script_list.cons x l, ids_to_copy, acc))\n (ctxt, Script_list.empty, ids_to_copy, acc)\n l.elements\n >|=? fun (ctxt, l, ids_to_copy, acc) ->\n let reversed = Script_list.rev l in\n (ctxt, reversed, ids_to_copy, acc)\n | Map_f has_lazy_storage, Map_t (_, ty, _), map ->\n let (module M) = Script_map.get_module map in\n let bindings m = M.OPS.fold (fun k v bs -> (k, v) :: bs) m [] in\n List.fold_left_es\n (fun (ctxt, m, ids_to_copy, acc) (k, x) ->\n aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage\n >|=? fun (ctxt, x, ids_to_copy, acc) ->\n (ctxt, M.OPS.add k x m, ids_to_copy, acc))\n (ctxt, M.OPS.empty, ids_to_copy, acc)\n (bindings M.boxed)\n >|=? fun (ctxt, m, ids_to_copy, acc) ->\n let module M = struct\n module OPS = M.OPS\n\n type key = M.key\n\n type value = M.value\n\n let boxed = m\n\n let size = M.size\n end in\n ( ctxt,\n Script_map.make\n (module M : Boxed_map\n with type key = M.key\n and type value = M.value),\n ids_to_copy,\n acc )\n | _, Option_t (_, _, _), None -> return (ctxt, None, ids_to_copy, acc)\n in\n let has_lazy_storage = has_lazy_storage ty in\n aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage\n\n(** We namespace an error type for [fold_lazy_storage]. The error case is only\n available when the ['error] parameter is equal to unit. *)\nmodule Fold_lazy_storage = struct\n type ('acc, 'error) result =\n | Ok : 'acc -> ('acc, 'error) result\n | Error : ('acc, unit) result\nend\n\n(** Prematurely abort if [f] generates an error. Use this function without the\n [unit] type for [error] if you are in a case where errors are impossible.\n*)\nlet rec fold_lazy_storage :\n type a ac error.\n f:('acc, error) Fold_lazy_storage.result Lazy_storage.IdSet.fold_f ->\n init:'acc ->\n context ->\n (a, ac) ty ->\n a ->\n has_lazy_storage:a has_lazy_storage ->\n (('acc, error) Fold_lazy_storage.result * context) tzresult =\n fun ~f ~init ctxt ty x ~has_lazy_storage ->\n Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt ->\n match (has_lazy_storage, ty, x) with\n | Big_map_f, Big_map_t (_, _, _), Big_map {id = Some id; _} ->\n Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt ->\n ok (f.f Big_map id (Fold_lazy_storage.Ok init), ctxt)\n | Sapling_state_f, Sapling_state_t _, {id = Some id; _} ->\n Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt ->\n ok (f.f Sapling_state id (Fold_lazy_storage.Ok init), ctxt)\n | False_f, _, _ -> ok (Fold_lazy_storage.Ok init, ctxt)\n | Big_map_f, Big_map_t (_, _, _), Big_map {id = None; _} ->\n ok (Fold_lazy_storage.Ok init, ctxt)\n | Sapling_state_f, Sapling_state_t _, {id = None; _} ->\n ok (Fold_lazy_storage.Ok init, ctxt)\n | Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (xl, xr) -> (\n fold_lazy_storage ~f ~init ctxt tyl xl ~has_lazy_storage:hl\n >>? fun (init, ctxt) ->\n match init with\n | Fold_lazy_storage.Ok init ->\n fold_lazy_storage ~f ~init ctxt tyr xr ~has_lazy_storage:hr\n | Fold_lazy_storage.Error -> ok (init, ctxt))\n | Union_f (has_lazy_storage, _), Union_t (ty, _, _, _), L x ->\n fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage\n | Union_f (_, has_lazy_storage), Union_t (_, ty, _, _), R x ->\n fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage\n | _, Option_t (_, _, _), None -> ok (Fold_lazy_storage.Ok init, ctxt)\n | Option_f has_lazy_storage, Option_t (ty, _, _), Some x ->\n fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage\n | List_f has_lazy_storage, List_t (ty, _), l ->\n List.fold_left_e\n (fun ((init, ctxt) : ('acc, error) Fold_lazy_storage.result * context) x ->\n match init with\n | Fold_lazy_storage.Ok init ->\n fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage\n | Fold_lazy_storage.Error -> ok (init, ctxt))\n (Fold_lazy_storage.Ok init, ctxt)\n l.elements\n | Map_f has_lazy_storage, Map_t (_, ty, _), m ->\n Script_map.fold\n (fun _\n v\n (acc : (('acc, error) Fold_lazy_storage.result * context) tzresult) ->\n acc >>? fun (init, ctxt) ->\n match init with\n | Fold_lazy_storage.Ok init ->\n fold_lazy_storage ~f ~init ctxt ty v ~has_lazy_storage\n | Fold_lazy_storage.Error -> ok (init, ctxt))\n m\n (ok (Fold_lazy_storage.Ok init, ctxt))\n\nlet collect_lazy_storage ctxt ty x =\n let has_lazy_storage = has_lazy_storage ty in\n let f kind id (acc : (_, never) Fold_lazy_storage.result) =\n let acc = match acc with Fold_lazy_storage.Ok acc -> acc in\n Fold_lazy_storage.Ok (Lazy_storage.IdSet.add kind id acc)\n in\n fold_lazy_storage ~f:{f} ~init:no_lazy_storage_id ctxt ty x ~has_lazy_storage\n >>? fun (ids, ctxt) ->\n match ids with Fold_lazy_storage.Ok ids -> ok (ids, ctxt)\n\nlet extract_lazy_storage_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v\n =\n (*\n Basically [to_duplicate] are ids from the argument and [to_update] are ids\n from the storage before execution (i.e. it is safe to reuse them since they\n will be owned by the same contract).\n *)\n let to_duplicate = Lazy_storage.IdSet.diff to_duplicate to_update in\n extract_lazy_storage_updates ctxt mode ~temporary to_duplicate [] ty v\n >|=? fun (ctxt, v, alive, diffs) ->\n let diffs =\n if temporary then diffs\n else\n let dead = Lazy_storage.IdSet.diff to_update alive in\n Lazy_storage.IdSet.fold_all\n {f = (fun kind id acc -> Lazy_storage.make kind id Remove :: acc)}\n dead\n diffs\n in\n match diffs with\n | [] -> (v, None, ctxt)\n | diffs -> (v, Some diffs (* do not reverse *), ctxt)\n\nlet list_of_big_map_ids ids =\n Lazy_storage.IdSet.fold Big_map (fun id acc -> id :: acc) ids []\n\nlet parse_data ~elab_conf ctxt ~allow_forged ty t =\n parse_data ~unparse_code_rec ~elab_conf ~allow_forged ~stack_depth:0 ctxt ty t\n\nlet parse_view ~elab_conf ctxt ty view =\n parse_view ~unparse_code_rec ~elab_conf ctxt ty view\n\nlet parse_views ~elab_conf ctxt ty views =\n parse_views ~unparse_code_rec ~elab_conf ctxt ty views\n\nlet parse_code ~elab_conf ctxt ~code =\n parse_code ~unparse_code_rec ~elab_conf ctxt ~code\n\nlet parse_storage ~elab_conf ctxt ~allow_forged ty ~storage =\n parse_storage ~unparse_code_rec ~elab_conf ctxt ~allow_forged ty ~storage\n\nlet parse_script ~elab_conf ctxt ~allow_forged_in_storage script =\n parse_script ~unparse_code_rec ~elab_conf ctxt ~allow_forged_in_storage script\n\nlet parse_comparable_data ?type_logger ctxt ty t =\n parse_data\n ~elab_conf:Script_ir_translator_config.(make ~legacy:false ?type_logger ())\n ~allow_forged:false\n ctxt\n ty\n t\n\nlet parse_instr :\n type a s.\n elab_conf:elab_conf ->\n tc_context ->\n context ->\n Script.node ->\n (a, s) stack_ty ->\n ((a, s) judgement * context) tzresult Lwt.t =\n fun ~elab_conf tc_context ctxt script_instr stack_ty ->\n parse_instr\n ~unparse_code_rec\n ~elab_conf\n ~stack_depth:0\n tc_context\n ctxt\n script_instr\n stack_ty\n\nlet unparse_data = unparse_data ~stack_depth:0\n\nlet unparse_code ctxt mode code =\n (* Constants need to be expanded or [unparse_code] may fail. *)\n Global_constants_storage.expand ctxt (strip_locations code)\n >>=? fun (ctxt, code) -> unparse_code ~stack_depth:0 ctxt mode (root code)\n\nlet parse_contract_data context loc arg_ty contract ~entrypoint =\n parse_contract_data ~stack_depth:0 context loc arg_ty contract ~entrypoint\n\nlet parse_toplevel ctxt ~legacy toplevel =\n Global_constants_storage.expand ctxt toplevel >>=? fun (ctxt, toplevel) ->\n Lwt.return @@ parse_toplevel ctxt ~legacy toplevel\n\nlet parse_comparable_ty = parse_comparable_ty ~stack_depth:0\n\nlet parse_big_map_value_ty = parse_big_map_value_ty ~stack_depth:0\n\nlet parse_packable_ty = parse_packable_ty ~stack_depth:0\n\nlet parse_passable_ty = parse_passable_ty ~stack_depth:0\n\nlet parse_any_ty = parse_any_ty ~stack_depth:0\n\nlet parse_ty = parse_ty ~stack_depth:0 ~ret:Don't_parse_entrypoints\n\nlet parse_parameter_ty_and_entrypoints =\n parse_parameter_ty_and_entrypoints ~stack_depth:0\n\nlet get_single_sapling_state ctxt ty x =\n let has_lazy_storage = has_lazy_storage ty in\n let f (type i a u) (kind : (i, a, u) Lazy_storage.Kind.t) (id : i)\n single_id_opt : (Sapling.Id.t option, unit) Fold_lazy_storage.result =\n match kind with\n | Lazy_storage.Kind.Sapling_state -> (\n match single_id_opt with\n | Fold_lazy_storage.Ok None -> Fold_lazy_storage.Ok (Some id)\n | Fold_lazy_storage.Ok (Some _) ->\n Fold_lazy_storage.Error (* more than one *)\n | Fold_lazy_storage.Error -> single_id_opt)\n | _ -> single_id_opt\n in\n fold_lazy_storage ~f:{f} ~init:None ctxt ty x ~has_lazy_storage\n >>? fun (id, ctxt) ->\n match id with\n | Fold_lazy_storage.Ok (Some id) -> ok (Some id, ctxt)\n | Fold_lazy_storage.Ok None | Fold_lazy_storage.Error -> ok (None, ctxt)\n\n(*\n\n {!Script_cache} needs a measure of the script size in memory.\n Determining this size is not easy in OCaml because of sharing.\n\n Indeed, many values present in the script share the same memory\n area. This is especially true for types and stack types: they are\n heavily shared in every typed IR internal representation. As a\n consequence, computing the size of the typed IR without taking\n sharing into account leads to a size which is sometimes two order\n of magnitude bigger than the actual size.\n\n We could track down this sharing. Unfortunately, sharing is not\n part of OCaml semantics: for this reason, a compiler can optimize\n memory representation by adding more sharing. If two nodes use\n different optimization flags or compilers, such a precise\n computation of the memory footprint of scripts would lead to two\n distinct sizes. As these sizes occur in the blockchain context,\n this situation would lead to a fork.\n\n For this reason, we introduce a *size model* for the script size.\n This model provides an overapproximation of the actual size in\n memory. The risk is to be too far from the actual size: the cache\n would then be wrongly marked as full. This situation would make the\n cache less useful but should present no security risk .\n\n*)\nlet script_size\n (Ex_script\n (Script\n {\n code_size;\n code = _;\n arg_type = _;\n storage;\n storage_type;\n entrypoints = _;\n views = _;\n })) =\n let nodes, storage_size =\n Script_typed_ir_size.value_size storage_type storage\n in\n let cost = Script_typed_ir_size_costs.nodes_cost ~nodes in\n (Saturation_repr.(add code_size storage_size |> to_int), cost)\n\nlet typecheck_code ~legacy ~show_types ctxt code =\n typecheck_code ~unparse_code_rec ~legacy ~show_types ctxt code\n >|=? fun (Typechecked_code_internal {type_map; _}, ctxt) -> (type_map, ctxt)\n" ;
} ;
{ name = "Script_big_map" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech <contact@trili.tech> *)\n(* Copyright (c) 2022 Marigold <team@marigold.dev> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\n(** [empty] is the big map with no bindings. *)\nval empty :\n 'a Script_typed_ir.comparable_ty ->\n ('b, _) Script_typed_ir.ty ->\n ('a, 'b) Script_typed_ir.big_map\n\n(** [mem ctxt key big_map] returns [true] iff [key] is bound in the\n given [big_map].\n Consumes the cost of hashing the given key.\n Consumes as [Storage.Big_map.Contents.mem] if the key is not bound\n yet in the current overlay. *)\nval mem :\n context ->\n 'key ->\n ('key, 'value) Script_typed_ir.big_map ->\n (bool * context) tzresult Lwt.t\n\n(** [get ctxt key big_map] returns the value bound by [key] in the\n given [big_map]. If the [key] is not bound, [None] is returned instead.\n Consumes cost of hashing the given key.\n Consumes cost as [Storage.Big_map.Contents.find] in case of the given key\n is absent in the current overlay.\n Consumes cost of parsing data if the value is readed from storage. *)\nval get :\n context ->\n 'key ->\n ('key, 'value) Script_typed_ir.big_map ->\n ('value option * context) tzresult Lwt.t\n\n(** [update ctxt key new_value big_map] updates the value bound by [key]\n with [v] if the [new_value] is [Some v]. When the [new_value] is [None],\n delete the entire entry bound by [key] in the [big_map].\n Consumes cost for hashing the given key.\n See {!get_and_update} for details. *)\nval update :\n context ->\n 'key ->\n 'value option ->\n ('key, 'value) Script_typed_ir.big_map ->\n (('key, 'value) Script_typed_ir.big_map * context) tzresult Lwt.t\n\n(** [get_and_update ctxt key new_value big_map] works just like\n [update ctxt key new_value big_map] except it also returns\n the old value bound by [key].\n Consumes cost for hashing the given key.\n This does {i not} modify the underlying storage, only the diff table. *)\nval get_and_update :\n context ->\n 'key ->\n 'value option ->\n ('key, 'value) Script_typed_ir.big_map ->\n (('value option * ('key, 'value) Script_typed_ir.big_map) * context) tzresult\n Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech <contact@trili.tech> *)\n(* Copyright (c) 2022 Marigold <team@marigold.dev> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Script_typed_ir\nopen Script_ir_translator\n\nlet empty key_type value_type =\n Big_map\n {\n id = None;\n diff = {map = Big_map_overlay.empty; size = 0};\n key_type;\n value_type;\n }\n\nlet mem ctxt key (Big_map {id; diff; key_type; _}) =\n hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) ->\n match (Big_map_overlay.find key_hash diff.map, id) with\n | None, None -> return (false, ctxt)\n | None, Some id ->\n Alpha_context.Big_map.mem ctxt id key_hash >|=? fun (ctxt, res) ->\n (res, ctxt)\n | Some (_, None), _ -> return (false, ctxt)\n | Some (_, Some _), _ -> return (true, ctxt)\n\nlet get_by_hash ctxt key (Big_map {id; diff; value_type; _}) =\n match (Big_map_overlay.find key diff.map, id) with\n | Some (_, x), _ -> return (x, ctxt)\n | None, None -> return (None, ctxt)\n | None, Some id -> (\n Alpha_context.Big_map.get_opt ctxt id key >>=? function\n | ctxt, None -> return (None, ctxt)\n | ctxt, Some value ->\n parse_data\n ctxt\n ~elab_conf:Script_ir_translator_config.(make ~legacy:true ())\n ~allow_forged:true\n value_type\n (Micheline.root value)\n >|=? fun (x, ctxt) -> (Some x, ctxt))\n\nlet get ctxt key (Big_map {key_type; _} as map) =\n hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) ->\n get_by_hash ctxt key_hash map\n\nlet update_by_hash key_hash key value (Big_map map) =\n let contains = Big_map_overlay.mem key_hash map.diff.map in\n Big_map\n {\n map with\n diff =\n {\n map = Big_map_overlay.add key_hash (key, value) map.diff.map;\n size = (if contains then map.diff.size else map.diff.size + 1);\n };\n }\n\nlet update ctxt key value (Big_map {key_type; _} as map) =\n hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) ->\n let map = update_by_hash key_hash key value map in\n return (map, ctxt)\n\nlet get_and_update ctxt key value (Big_map {key_type; _} as map) =\n hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) ->\n let new_map = update_by_hash key_hash key value map in\n get_by_hash ctxt key_hash map >>=? fun (old_value, ctxt) ->\n return ((old_value, new_map), ctxt)\n" ;
} ;
{ name = "Script_cache" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module manages the cache for smart contracts.\n\n This cache must be consistent with the on-disk representation\n of the smart contracts. In particular, [update] must be called\n each time a contract storage is updated.\n\n*)\n\nopen Alpha_context\n\n(** Each cached script has a unique identifier in the cache. *)\ntype identifier\n\n(** The cache holds the unparsed and the internal representation of\n the contract. *)\ntype cached_contract = Script.t * Script_ir_translator.ex_script\n\n(** [find ctxt contract] returns [(ctxt', identifier, script)] where:\n - [ctxt'] is [ctxt] with less gas;\n - [identifier] is the identifier identifying the [contract] in the cache;\n - [script = None] if there is no such contract in [ctxt];\n - [script = Some (unparsed_script, ir_script)] where\n - [unparsed_script] is the contract source code and storage;\n - [script_ir] is a typed internal representation of the contract, i.e.,\n the abstract syntax tree of its code as well as its storage.\n\n This function consumes gas depending on the cache. If the contract is not\n in the cache, then the function also consumes the gas of [Contract.get_script]\n and [Script_ir_translator.parse_script]. *)\nval find :\n context ->\n Contract_hash.t ->\n (context * identifier * cached_contract option) tzresult Lwt.t\n\n(** [update ctxt identifier unparsed_script ir_script size] refreshes the\n cached contract identified by [identifier] with a new [unparsed_script],\n a new [ir_script], and a new size. *)\nval update : context -> identifier -> cached_contract -> int -> context tzresult\n\n(** [entries ctxt] returns the contracts in the cache as well as their\n respective size. The list is sorted by date of last modification:\n the least recently updated entry comes first. *)\nval entries : context -> (Contract_hash.t * int) list tzresult\n\n(** [contract_rank ctxt contract] returns the number of contracts\n older than [contract] in the cache of [ctxt]. This function\n returns [None] if [contract] does not exist in the cache of\n [ctxt]. *)\nval contract_rank : context -> Contract_hash.t -> int option\n\n(** [size ctxt] is an overapproximation of the cache size in\n memory (in bytes). *)\nval size : context -> int\n\n(** [size_limit ctxt] is the maximal size of the cache (in bytes). *)\nval size_limit : context -> int\n\n(** [insert] is a variant of [update] which identifies the contract to update\n by its address (of type [Contract_hash.t]) instead of its cache identifier. *)\nval insert :\n context -> Contract_hash.t -> cached_contract -> int -> context tzresult\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\ntype identifier = string\n\nlet identifier_of_contract addr = Contract_hash.to_b58check addr\n\nlet contract_of_identifier identifier =\n match Contract_hash.of_b58check_opt identifier with\n | Some addr -> Ok addr\n | None -> error (Contract_repr.Invalid_contract_notation identifier)\n\ntype cached_contract = Script.t * Script_ir_translator.ex_script\n\nlet load_and_elaborate ctxt addr =\n Contract.get_script ctxt addr >>=? fun (ctxt, script) ->\n match script with\n | None -> return (ctxt, None)\n | Some script ->\n Script_ir_translator.(\n parse_script\n ctxt\n script\n ~elab_conf:Script_ir_translator_config.(make ~legacy:true ())\n ~allow_forged_in_storage:true\n >>=? fun (ex_script, ctxt) ->\n (* We consume gas after the fact in order to not have to instrument\n [script_size] (for efficiency).\n This is safe, as we already pay gas proportional to storage size\n in [parse_script] beforehand. *)\n let size, cost = script_size ex_script in\n Gas.consume ctxt cost >>?= fun ctxt ->\n return (ctxt, Some (script, ex_script, size)))\n\nmodule Client = struct\n type cached_value = cached_contract\n\n let namespace = Cache.create_namespace \"contract\"\n\n let cache_index = 0\n\n let value_of_identifier ctxt identifier =\n (*\n\n I/O, deserialization, and elaboration of contracts scripts\n are cached.\n\n *)\n contract_of_identifier identifier >>?= fun addr ->\n load_and_elaborate ctxt addr >>=? function\n | _, None ->\n (* [value_of_identifier ctxt k] is applied to identifiers stored\n in the cache. Only script-based contracts that have been\n executed are in the cache. Hence, [get_script] always\n succeeds for these identifiers if [ctxt] and the [cache] are\n properly synchronized by the shell. *)\n failwith \"Script_cache: Inconsistent script cache.\"\n | _, Some (unparsed_script, ir_script, _) ->\n return (unparsed_script, ir_script)\nend\n\nmodule Cache = (val Cache.register_exn (module Client))\n\nlet find ctxt addr =\n let identifier = identifier_of_contract addr in\n Cache.find ctxt identifier >>=? function\n | Some (unparsed_script, ex_script) ->\n return (ctxt, identifier, Some (unparsed_script, ex_script))\n | None -> (\n load_and_elaborate ctxt addr >>=? function\n | ctxt, None -> return (ctxt, identifier, None)\n | ctxt, Some (unparsed_script, script_ir, size) ->\n let cached_value = (unparsed_script, script_ir) in\n Lwt.return\n ( Cache.update ctxt identifier (Some (cached_value, size))\n >>? fun ctxt ->\n ok (ctxt, identifier, Some (unparsed_script, script_ir)) ))\n\nlet update ctxt identifier updated_script approx_size =\n Cache.update ctxt identifier (Some (updated_script, approx_size))\n\nlet entries ctxt =\n Cache.list_identifiers ctxt\n |> List.map_e @@ fun (identifier, age) ->\n contract_of_identifier identifier >|? fun contract -> (contract, age)\n\nlet contract_rank ctxt addr =\n Cache.identifier_rank ctxt (identifier_of_contract addr)\n\nlet size = Cache.size\n\nlet size_limit = Cache.size_limit\n\nlet insert ctxt addr updated_script approx_size =\n let identifier = identifier_of_contract addr in\n Cache.update ctxt identifier (Some (updated_script, approx_size))\n" ;
} ;
{ name = "Script_tc_errors_registration" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module registers all the errors from [Script_tc_errors] as a top-level\n effect. *)\n\nopen Alpha_context\nopen Script\n\nval type_map_enc :\n (location * (expr list * expr list)) list Data_encoding.encoding\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\nopen Script\nopen Script_tc_errors\n\n(* Helpers for encoding *)\nlet stack_ty_enc = Data_encoding.list Script.expr_encoding\n\nlet type_map_enc =\n let open Data_encoding in\n list\n (conv\n (fun (loc, (bef, aft)) -> (loc, bef, aft))\n (fun (loc, bef, aft) -> (loc, (bef, aft)))\n (obj3\n (req \"location\" Script.location_encoding)\n (req \"stack_before\" stack_ty_enc)\n (req \"stack_after\" stack_ty_enc)))\n\n(* main registration *)\nlet () =\n let open Data_encoding in\n let located enc =\n merge_objs (obj1 (req \"location\" Script.location_encoding)) enc\n in\n let arity_enc = int8 in\n let namespace_enc =\n def\n \"primitiveNamespace\"\n ~title:\"Primitive namespace\"\n ~description:\n \"One of the five possible namespaces of primitive (data constructor, \\\n type name, instruction, keyword, or constant hash).\"\n @@ string_enum\n [\n (\"type\", Michelson_v1_primitives.Type_namespace);\n (\"constant\", Constant_namespace);\n (\"instruction\", Instr_namespace);\n (\"keyword\", Keyword_namespace);\n (\"constant_hash\", Constant_hash_namespace);\n ]\n in\n let kind_enc =\n def\n \"expressionKind\"\n ~title:\"Expression kind\"\n ~description:\n \"One of the four possible kinds of expression (integer, string, \\\n primitive application or sequence).\"\n @@ string_enum\n [\n (\"integer\", Int_kind);\n (\"string\", String_kind);\n (\"bytes\", Bytes_kind);\n (\"primitiveApplication\", Prim_kind);\n (\"sequence\", Seq_kind);\n ]\n in\n let context_desc_enc =\n let open Data_encoding in\n def \"michelson_v1.context_desc\"\n @@ string_enum [(\"Lambda\", Lambda); (\"View\", View)]\n in\n (* -- Structure errors ---------------------- *)\n (* Invalid arity *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.invalid_arity\"\n ~title:\"Invalid arity\"\n ~description:\n \"In a script or data expression, a primitive was applied to an \\\n unsupported number of arguments.\"\n (located\n (obj3\n (req \"primitive_name\" Script.prim_encoding)\n (req \"expected_arity\" arity_enc)\n (req \"wrong_arity\" arity_enc)))\n (function\n | Invalid_arity (loc, name, exp, got) -> Some (loc, (name, exp, got))\n | _ -> None)\n (fun (loc, (name, exp, got)) -> Invalid_arity (loc, name, exp, got)) ;\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.invalid_seq_arity\"\n ~title:\"Invalid sequence arity\"\n ~description:\n \"In a script or data expression, a sequence was used with a number of \\\n elements too small.\"\n (located\n (obj2\n (req \"minimal_expected_arity\" arity_enc)\n (req \"wrong_arity\" arity_enc)))\n (function\n | Invalid_seq_arity (loc, exp, got) -> Some (loc, (exp, got)) | _ -> None)\n (fun (loc, (exp, got)) -> Invalid_seq_arity (loc, exp, got)) ;\n (* Missing field *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.missing_script_field\"\n ~title:\"Script is missing a field (parse error)\"\n ~description:\"When parsing script, a field was expected, but not provided\"\n (obj1 (req \"prim\" prim_encoding))\n (function Missing_field prim -> Some prim | _ -> None)\n (fun prim -> Missing_field prim) ;\n (* Invalid primitive *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.invalid_primitive\"\n ~title:\"Invalid primitive\"\n ~description:\"In a script or data expression, a primitive was unknown.\"\n (located\n (obj2\n (dft \"expected_primitive_names\" (list prim_encoding) [])\n (req \"wrong_primitive_name\" prim_encoding)))\n (function\n | Invalid_primitive (loc, exp, got) -> Some (loc, (exp, got)) | _ -> None)\n (fun (loc, (exp, got)) -> Invalid_primitive (loc, exp, got)) ;\n (* Invalid kind *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.invalid_expression_kind\"\n ~title:\"Invalid expression kind\"\n ~description:\n \"In a script or data expression, an expression was of the wrong kind \\\n (for instance a string where only a primitive applications can appear).\"\n (located\n (obj2 (req \"expected_kinds\" (list kind_enc)) (req \"wrong_kind\" kind_enc)))\n (function\n | Invalid_kind (loc, exp, got) -> Some (loc, (exp, got)) | _ -> None)\n (fun (loc, (exp, got)) -> Invalid_kind (loc, exp, got)) ;\n (* Invalid namespace *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.invalid_primitive_namespace\"\n ~title:\"Invalid primitive namespace\"\n ~description:\n \"In a script or data expression, a primitive was of the wrong namespace.\"\n (located\n (obj3\n (req \"primitive_name\" prim_encoding)\n (req \"expected_namespace\" namespace_enc)\n (req \"wrong_namespace\" namespace_enc)))\n (function\n | Invalid_namespace (loc, name, exp, got) -> Some (loc, (name, exp, got))\n | _ -> None)\n (fun (loc, (name, exp, got)) -> Invalid_namespace (loc, name, exp, got)) ;\n (* Invalid literal for type never *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.invalid_never_expr\"\n ~title:\"Invalid expression for type never\"\n ~description:\n \"In a script or data expression, an expression was provided but a value \\\n of type never was expected. No expression can have type never.\"\n (located unit)\n (function Invalid_never_expr loc -> Some (loc, ()) | _ -> None)\n (fun (loc, ()) -> Invalid_never_expr loc) ;\n (* Duplicate field *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.duplicate_script_field\"\n ~title:\"Script has a duplicated field (parse error)\"\n ~description:\"When parsing script, a field was found more than once\"\n (obj2 (req \"loc\" location_encoding) (req \"prim\" prim_encoding))\n (function Duplicate_field (loc, prim) -> Some (loc, prim) | _ -> None)\n (fun (loc, prim) -> Duplicate_field (loc, prim)) ;\n (* Unexpected big_map *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.unexpected_lazy_storage\"\n ~title:\"Lazy storage in unauthorized position (type error)\"\n ~description:\n \"When parsing script, a big_map or sapling_state type was found in a \\\n position where it could end up stored inside a big_map, which is \\\n forbidden for now.\"\n (obj1 (req \"loc\" location_encoding))\n (function Unexpected_lazy_storage loc -> Some loc | _ -> None)\n (fun loc -> Unexpected_lazy_storage loc) ;\n (* Unexpected operation *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.unexpected_operation\"\n ~title:\"Operation in unauthorized position (type error)\"\n ~description:\n \"When parsing script, an operation type was found in the storage or \\\n parameter field.\"\n (obj1 (req \"loc\" location_encoding))\n (function Unexpected_operation loc -> Some loc | _ -> None)\n (fun loc -> Unexpected_operation loc) ;\n (* No such entrypoint *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.no_such_entrypoint\"\n ~title:\"No such entrypoint (type error)\"\n ~description:\"An entrypoint was not found when calling a contract.\"\n (obj1 (req \"entrypoint\" Entrypoint.simple_encoding))\n (function No_such_entrypoint entrypoint -> Some entrypoint | _ -> None)\n (fun entrypoint -> No_such_entrypoint entrypoint) ;\n (* Unreachable entrypoint *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.unreachable_entrypoint\"\n ~title:\"Unreachable entrypoint (type error)\"\n ~description:\"An entrypoint in the contract is not reachable.\"\n (obj1 (req \"path\" (list prim_encoding)))\n (function Unreachable_entrypoint path -> Some path | _ -> None)\n (fun path -> Unreachable_entrypoint path) ;\n (* Tx rollup bad deposit parameter *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.tx_rollup_bad_deposit_parameter\"\n ~title:\"Bad deposit parameter\"\n ~description:\n \"The parameter to the deposit entrypoint of a transaction rollup should \\\n be a pair of a ticket and the address of a recipient transaction \\\n rollup.\"\n (located (obj1 (req \"parameter\" Script.expr_encoding)))\n (function\n | Tx_rollup_bad_deposit_parameter (loc, expr) -> Some (loc, expr)\n | _ -> None)\n (fun (loc, expr) -> Tx_rollup_bad_deposit_parameter (loc, expr)) ;\n (* Tx rollup invalid ticket amount *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.invalid_tx_rollup_ticket_amount\"\n ~title:\"Invalid ticket amount\"\n ~description:\n \"Ticket amount to be deposited in a transaction rollup should be \\\n strictly positive and fit in a signed 64-bit integer\"\n (obj1 (req \"requested_value\" Data_encoding.z))\n (function Tx_rollup_invalid_ticket_amount z -> Some z | _ -> None)\n (fun z -> Tx_rollup_invalid_ticket_amount z) ;\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.forbidden_zero_amount_ticket\"\n ~title:\"Zero ticket amount is not allowed\"\n ~description:\n \"It is not allowed to use a zero amount ticket in this operation.\"\n Data_encoding.empty\n (function Forbidden_zero_ticket_quantity -> Some () | _ -> None)\n (fun () -> Forbidden_zero_ticket_quantity) ;\n (* Tx rollup addresses disabled *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.tx_rollup_addresses_disabled\"\n ~title:\"Tx rollup addresses are disabled\"\n ~description:\"Cannot parse a tx_rollup address as tx rollups are disabled.\"\n (obj1 (req \"location\" Script.location_encoding))\n (function Tx_rollup_addresses_disabled loc -> Some loc | _ -> None)\n (fun loc -> Tx_rollup_addresses_disabled loc) ;\n (* Sc rollup disabled *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.sc_rollup_disabled\"\n ~title:\"Sc rollup are disabled\"\n ~description:\"Cannot use smart rollup features as they are disabled.\"\n (obj1 (req \"location\" Script.location_encoding))\n (function Sc_rollup_disabled loc -> Some loc | _ -> None)\n (fun loc -> Sc_rollup_disabled loc) ;\n (* Duplicate entrypoint *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.duplicate_entrypoint\"\n ~title:\"Duplicate entrypoint (type error)\"\n ~description:\"Two entrypoints have the same name.\"\n (obj1 (req \"path\" Entrypoint.simple_encoding))\n (function Duplicate_entrypoint entrypoint -> Some entrypoint | _ -> None)\n (fun entrypoint -> Duplicate_entrypoint entrypoint) ;\n (* Unexpected contract *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.unexpected_contract\"\n ~title:\"Contract in unauthorized position (type error)\"\n ~description:\n \"When parsing script, a contract type was found in the storage or \\\n parameter field.\"\n (obj1 (req \"loc\" location_encoding))\n (function Unexpected_contract loc -> Some loc | _ -> None)\n (fun loc -> Unexpected_contract loc) ;\n (* -- Value typing errors ---------------------- *)\n (* Unordered map keys *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.unordered_map_literal\"\n ~title:\"Invalid map key order\"\n ~description:\"Map keys must be in strictly increasing order\"\n (obj2\n (req \"location\" Script.location_encoding)\n (req \"item\" Script.expr_encoding))\n (function Unordered_map_keys (loc, expr) -> Some (loc, expr) | _ -> None)\n (fun (loc, expr) -> Unordered_map_keys (loc, expr)) ;\n (* Duplicate map keys *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.duplicate_map_keys\"\n ~title:\"Duplicate map keys\"\n ~description:\"Map literals cannot contain duplicated keys\"\n (obj2\n (req \"location\" Script.location_encoding)\n (req \"item\" Script.expr_encoding))\n (function Duplicate_map_keys (loc, expr) -> Some (loc, expr) | _ -> None)\n (fun (loc, expr) -> Duplicate_map_keys (loc, expr)) ;\n (* Unordered set values *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.unordered_set_literal\"\n ~title:\"Invalid set value order\"\n ~description:\"Set values must be in strictly increasing order\"\n (obj2\n (req \"location\" Script.location_encoding)\n (req \"value\" Script.expr_encoding))\n (function\n | Unordered_set_values (loc, expr) -> Some (loc, expr) | _ -> None)\n (fun (loc, expr) -> Unordered_set_values (loc, expr)) ;\n (* Duplicate set values *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.duplicate_set_values_in_literal\"\n ~title:\"Sets literals cannot contain duplicate elements\"\n ~description:\n \"Set literals cannot contain duplicate elements, but a duplicate was \\\n found while parsing.\"\n (obj2\n (req \"location\" Script.location_encoding)\n (req \"value\" Script.expr_encoding))\n (function\n | Duplicate_set_values (loc, expr) -> Some (loc, expr) | _ -> None)\n (fun (loc, expr) -> Duplicate_set_values (loc, expr)) ;\n (* -- Instruction typing errors ------------- *)\n (* Fail not in tail position *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.fail_not_in_tail_position\"\n ~title:\"FAIL not in tail position\"\n ~description:\"There is non trivial garbage code after a FAIL instruction.\"\n (located empty)\n (function Fail_not_in_tail_position loc -> Some (loc, ()) | _ -> None)\n (fun (loc, ()) -> Fail_not_in_tail_position loc) ;\n (* Undefined binary operation *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.undefined_binop\"\n ~title:\"Undefined binop\"\n ~description:\n \"A binary operation is called on operands of types over which it is not \\\n defined.\"\n (located\n (obj3\n (req \"operator_name\" prim_encoding)\n (req \"wrong_left_operand_type\" Script.expr_encoding)\n (req \"wrong_right_operand_type\" Script.expr_encoding)))\n (function\n | Undefined_binop (loc, n, tyl, tyr) -> Some (loc, (n, tyl, tyr))\n | _ -> None)\n (fun (loc, (n, tyl, tyr)) -> Undefined_binop (loc, n, tyl, tyr)) ;\n (* Undefined unary operation *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.undefined_unop\"\n ~title:\"Undefined unop\"\n ~description:\n \"A unary operation is called on an operand of type over which it is not \\\n defined.\"\n (located\n (obj2\n (req \"operator_name\" prim_encoding)\n (req \"wrong_operand_type\" Script.expr_encoding)))\n (function Undefined_unop (loc, n, ty) -> Some (loc, (n, ty)) | _ -> None)\n (fun (loc, (n, ty)) -> Undefined_unop (loc, n, ty)) ;\n (* Bad return *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.bad_return\"\n ~title:\"Bad return\"\n ~description:\"Unexpected stack at the end of a lambda or script.\"\n (located\n (obj2\n (req \"expected_return_type\" Script.expr_encoding)\n (req \"wrong_stack_type\" stack_ty_enc)))\n (function Bad_return (loc, sty, ty) -> Some (loc, (ty, sty)) | _ -> None)\n (fun (loc, (ty, sty)) -> Bad_return (loc, sty, ty)) ;\n (* Bad stack *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.bad_stack\"\n ~title:\"Bad stack\"\n ~description:\"The stack has an unexpected length or contents.\"\n (located\n (obj3\n (req \"primitive_name\" prim_encoding)\n (req \"relevant_stack_portion\" int16)\n (req \"wrong_stack_type\" stack_ty_enc)))\n (function\n | Bad_stack (loc, name, s, sty) -> Some (loc, (name, s, sty)) | _ -> None)\n (fun (loc, (name, s, sty)) -> Bad_stack (loc, name, s, sty)) ;\n (* Unexpected annotation *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.unexpected_annotation\"\n ~title:\"An annotation was encountered where no annotation is expected\"\n ~description:\"A node in the syntax tree was improperly annotated\"\n (located empty)\n (function Unexpected_annotation loc -> Some (loc, ()) | _ -> None)\n (fun (loc, ()) -> Unexpected_annotation loc) ;\n (* Ungrouped annotations *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.ungrouped_annotations\"\n ~title:\"Annotations of the same kind were found spread apart\"\n ~description:\"Annotations of the same kind must be grouped\"\n (located empty)\n (function Ungrouped_annotations loc -> Some (loc, ()) | _ -> None)\n (fun (loc, ()) -> Ungrouped_annotations loc) ;\n (* Unmatched branches *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.unmatched_branches\"\n ~title:\"Unmatched branches\"\n ~description:\n \"At the join point at the end of two code branches the stacks have \\\n inconsistent lengths or contents.\"\n (located\n (obj2\n (req \"first_stack_type\" stack_ty_enc)\n (req \"other_stack_type\" stack_ty_enc)))\n (function\n | Unmatched_branches (loc, stya, styb) -> Some (loc, (stya, styb))\n | _ -> None)\n (fun (loc, (stya, styb)) -> Unmatched_branches (loc, stya, styb)) ;\n (* Bad stack item *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.bad_stack_item\"\n ~title:\"Bad stack item\"\n ~description:\n \"The type of a stack item is unexpected (this error is always \\\n accompanied by a more precise one).\"\n (obj1 (req \"item_level\" int16))\n (function Bad_stack_item n -> Some n | _ -> None)\n (fun n -> Bad_stack_item n) ;\n (* Forbidden instruction in a context. *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.forbidden_instr_in_context\"\n ~title:\"Forbidden instruction in context\"\n ~description:\n \"An instruction was encountered in a context where it is forbidden.\"\n (located\n (obj2\n (req \"context\" context_desc_enc)\n (req \"forbidden_instruction\" prim_encoding)))\n (function\n | Forbidden_instr_in_context (loc, ctxt, prim) -> Some (loc, (ctxt, prim))\n | _ -> None)\n (fun (loc, (ctxt, prim)) -> Forbidden_instr_in_context (loc, ctxt, prim)) ;\n (* Bad stack length *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.inconsistent_stack_lengths\"\n ~title:\"Inconsistent stack lengths\"\n ~description:\n \"A stack was of an unexpected length (this error is always in the \\\n context of a located error).\"\n empty\n (function Bad_stack_length -> Some () | _ -> None)\n (fun () -> Bad_stack_length) ;\n (* -- Value typing errors ------------------- *)\n (* Invalid constant *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.invalid_constant\"\n ~title:\"Invalid constant\"\n ~description:\"A data expression was invalid for its expected type.\"\n (located\n (obj2\n (req \"expected_type\" Script.expr_encoding)\n (req \"wrong_expression\" Script.expr_encoding)))\n (function\n | Invalid_constant (loc, expr, ty) -> Some (loc, (ty, expr)) | _ -> None)\n (fun (loc, (ty, expr)) -> Invalid_constant (loc, expr, ty)) ;\n (* View name too long *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.view_name_too_long\"\n ~title:\"View name too long (type error)\"\n ~description:\"A view name exceeds the maximum length of 31 characters.\"\n (obj1 (req \"name\" (string Plain)))\n (function View_name_too_long name -> Some name | _ -> None)\n (fun name -> View_name_too_long name) ;\n (* Duplicated view name *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.duplicated_view_name\"\n ~title:\"Duplicated view name\"\n ~description:\"The name of view in toplevel should be unique.\"\n (obj1 (req \"location\" Script.location_encoding))\n (function Duplicated_view_name loc -> Some loc | _ -> None)\n (fun loc -> Duplicated_view_name loc) ;\n (* Invalid syntactic constant *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.invalid_syntactic_constant\"\n ~title:\"Invalid constant (parse error)\"\n ~description:\"A compile-time constant was invalid for its expected form.\"\n (located\n (obj2\n (req \"expected_form\" (string Plain))\n (req \"wrong_expression\" Script.expr_encoding)))\n (function\n | Invalid_syntactic_constant (loc, expr, expected) ->\n Some (loc, (expected, expr))\n | _ -> None)\n (fun (loc, (expected, expr)) ->\n Invalid_syntactic_constant (loc, expr, expected)) ;\n (* Invalid contract *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.invalid_contract\"\n ~title:\"Invalid contract\"\n ~description:\n \"A script or data expression references a contract that does not exist \\\n or assumes a wrong type for an existing contract.\"\n (located (obj1 (req \"contract\" Contract.encoding)))\n (function Invalid_contract (loc, c) -> Some (loc, c) | _ -> None)\n (fun (loc, c) -> Invalid_contract (loc, c)) ;\n (* Invalid big_map *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.invalid_big_map\"\n ~title:\"Invalid big_map\"\n ~description:\n \"A script or data expression references a big_map that does not exist or \\\n assumes a wrong type for an existing big_map.\"\n (located (obj1 (req \"big_map\" Big_map.Id.encoding)))\n (function Invalid_big_map (loc, c) -> Some (loc, c) | _ -> None)\n (fun (loc, c) -> Invalid_big_map (loc, c)) ;\n (* Comparable type expected *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.comparable_type_expected\"\n ~title:\"Comparable type expected\"\n ~description:\n \"A non comparable type was used in a place where only comparable types \\\n are accepted.\"\n (located (obj1 (req \"wrong_type\" Script.expr_encoding)))\n (function\n | Comparable_type_expected (loc, ty) -> Some (loc, ty) | _ -> None)\n (fun (loc, ty) -> Comparable_type_expected (loc, ty)) ;\n (* Inconsistent type sizes *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.inconsistent_type_sizes\"\n ~title:\"Inconsistent type sizes\"\n ~description:\n \"Two types were expected to be equal but they have different sizes.\"\n (obj2 (req \"first_type_size\" int31) (req \"other_type_size\" int31))\n (function\n | Inconsistent_type_sizes (tya, tyb) -> Some (tya, tyb) | _ -> None)\n (fun (tya, tyb) -> Inconsistent_type_sizes (tya, tyb)) ;\n (* Inconsistent types *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.inconsistent_types\"\n ~title:\"Inconsistent types\"\n ~description:\n \"This is the basic type clash error, that appears in several places \\\n where the equality of two types have to be proven, it is always \\\n accompanied with another error that provides more context.\"\n (obj3\n (req \"loc\" Script.location_encoding)\n (req \"first_type\" Script.expr_encoding)\n (req \"other_type\" Script.expr_encoding))\n (function\n | Inconsistent_types (loc, tya, tyb) -> Some (loc, tya, tyb) | _ -> None)\n (fun (loc, tya, tyb) -> Inconsistent_types (loc, tya, tyb)) ;\n (* Inconsistent memo_sizes *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.inconsistent_memo_sizes\"\n ~title:\"Inconsistent memo sizes\"\n ~description:\"Memo sizes of two sapling states or transactions do not match\"\n (obj2\n (req \"first_memo_size\" Sapling.Memo_size.encoding)\n (req \"other_memo_size\" Sapling.Memo_size.encoding))\n (function\n | Inconsistent_memo_sizes (msa, msb) -> Some (msa, msb) | _ -> None)\n (fun (msa, msb) -> Inconsistent_memo_sizes (msa, msb)) ;\n (* -- Instruction typing errors ------------------- *)\n (* Bad view name *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.bad_view_name\"\n ~title:\"Bad view name\"\n ~description:\"In a view declaration, the view name must be a string\"\n (obj1 (req \"loc\" Script.location_encoding))\n (function Bad_view_name loc -> Some loc | _ -> None)\n (fun loc -> Bad_view_name loc) ;\n (* Invalid view body *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.ill_typed_view\"\n ~title:\"Ill typed view\"\n ~description:\"The return of a view block did not match the expected type\"\n (obj3\n (req \"loc\" Script.location_encoding)\n (req \"resulted_view_stack\" stack_ty_enc)\n (req \"expected_view_stack\" stack_ty_enc))\n (function\n | Ill_typed_view {loc; actual; expected} -> Some (loc, actual, expected)\n | _ -> None)\n (fun (loc, actual, expected) -> Ill_typed_view {loc; actual; expected}) ;\n (* Invalid map body *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.invalid_map_body\"\n ~title:\"Invalid map body\"\n ~description:\"The body of a map block did not match the expected type\"\n (obj2 (req \"loc\" Script.location_encoding) (req \"body_type\" stack_ty_enc))\n (function Invalid_map_body (loc, stack) -> Some (loc, stack) | _ -> None)\n (fun (loc, stack) -> Invalid_map_body (loc, stack)) ;\n (* Invalid map block FAIL *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.invalid_map_block_fail\"\n ~title:\"FAIL instruction occurred as body of map block\"\n ~description:\n \"FAIL cannot be the only instruction in the body. The proper type of the \\\n return list cannot be inferred.\"\n (obj1 (req \"loc\" Script.location_encoding))\n (function Invalid_map_block_fail loc -> Some loc | _ -> None)\n (fun loc -> Invalid_map_block_fail loc) ;\n (* Invalid ITER body *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.invalid_iter_body\"\n ~title:\"ITER body returned wrong stack type\"\n ~description:\n \"The body of an ITER instruction must result in the same stack type as \\\n before the ITER.\"\n (obj3\n (req \"loc\" Script.location_encoding)\n (req \"bef_stack\" stack_ty_enc)\n (req \"aft_stack\" stack_ty_enc))\n (function\n | Invalid_iter_body (loc, bef, aft) -> Some (loc, bef, aft) | _ -> None)\n (fun (loc, bef, aft) -> Invalid_iter_body (loc, bef, aft)) ;\n (* Type too large *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.type_too_large\"\n ~title:\"Stack item type too large\"\n ~description:\"An instruction generated a type larger than the limit.\"\n (obj2 (req \"loc\" Script.location_encoding) (req \"maximum_type_size\" uint16))\n (function Type_too_large (loc, maxts) -> Some (loc, maxts) | _ -> None)\n (fun (loc, maxts) -> Type_too_large (loc, maxts)) ;\n (* Bad PAIR argument *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.bad_pair_argument\"\n ~title:\"0 or 1 passed to PAIR\"\n ~description:\"PAIR expects an argument of at least 2\"\n (obj1 (req \"loc\" Script.location_encoding))\n (function Pair_bad_argument loc -> Some loc | _ -> None)\n (fun loc -> Pair_bad_argument loc) ;\n (* Bad UNPAIR argument *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.bad_unpair_argument\"\n ~title:\"0 or 1 passed to UNPAIR\"\n ~description:\"UNPAIR expects an argument of at least 2\"\n (obj1 (req \"loc\" Script.location_encoding))\n (function Unpair_bad_argument loc -> Some loc | _ -> None)\n (fun loc -> Unpair_bad_argument loc) ;\n (* Bad dup_n argument *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.bad_dupn_argument\"\n ~title:\"0 passed to DUP n\"\n ~description:\"DUP expects an argument of at least 1 (passed 0)\"\n (obj1 (req \"loc\" Script.location_encoding))\n (function Dup_n_bad_argument loc -> Some loc | _ -> None)\n (fun loc -> Dup_n_bad_argument loc) ;\n (* Bad dup_n stack *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.bad_dupn_stack\"\n ~title:\"Stack too short when typing DUP n\"\n ~description:\"Stack present when typing DUP n was too short\"\n (obj1 (req \"loc\" Script.location_encoding))\n (function Dup_n_bad_stack x -> Some x | _ -> None)\n (fun x -> Dup_n_bad_stack x) ;\n (* -- Toplevel errors ------------------- *)\n (* Ill typed data *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.ill_typed_data\"\n ~title:\"Ill typed data\"\n ~description:\n \"The toplevel error thrown when trying to typecheck a data expression \\\n against a given type (always followed by more precise errors).\"\n (obj3\n (opt \"identifier\" (string Plain))\n (req \"expected_type\" Script.expr_encoding)\n (req \"ill_typed_expression\" Script.expr_encoding))\n (function\n | Ill_typed_data (name, expr, ty) -> Some (name, ty, expr) | _ -> None)\n (fun (name, ty, expr) -> Ill_typed_data (name, expr, ty)) ;\n (* Ill formed type *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.ill_formed_type\"\n ~title:\"Ill formed type\"\n ~description:\n \"The toplevel error thrown when trying to parse a type expression \\\n (always followed by more precise errors).\"\n (obj3\n (opt \"identifier\" (string Plain))\n (req \"ill_formed_expression\" Script.expr_encoding)\n (req \"location\" Script.location_encoding))\n (function\n | Ill_formed_type (name, expr, loc) -> Some (name, expr, loc) | _ -> None)\n (fun (name, expr, loc) -> Ill_formed_type (name, expr, loc)) ;\n (* Ill typed contract *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.ill_typed_contract\"\n ~title:\"Ill typed contract\"\n ~description:\n \"The toplevel error thrown when trying to typecheck a contract code \\\n against given input, output and storage types (always followed by more \\\n precise errors).\"\n (obj2\n (req \"ill_typed_code\" Script.expr_encoding)\n (req \"type_map\" type_map_enc))\n (function\n | Ill_typed_contract (expr, type_map) -> Some (expr, type_map) | _ -> None)\n (fun (expr, type_map) -> Ill_typed_contract (expr, type_map)) ;\n (* Deprecated instruction *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.deprecated_instruction\"\n ~title:\"Script is using a deprecated instruction\"\n ~description:\n \"A deprecated instruction usage is disallowed in newly created contracts\"\n (obj1 (req \"prim\" prim_encoding))\n (function Deprecated_instruction prim -> Some prim | _ -> None)\n (fun prim -> Deprecated_instruction prim) ;\n (* Typechecking stack overflow *)\n register_error_kind\n `Temporary\n ~id:\"michelson_v1.typechecking_too_many_recursive_calls\"\n ~title:\"Too many recursive calls during typechecking\"\n ~description:\"Too many recursive calls were needed for typechecking\"\n Data_encoding.empty\n (function Typechecking_too_many_recursive_calls -> Some () | _ -> None)\n (fun () -> Typechecking_too_many_recursive_calls) ;\n (* Unparsing stack overflow *)\n register_error_kind\n `Temporary\n ~id:\"michelson_v1.unparsing_stack_overflow\"\n ~title:\"Too many recursive calls during unparsing\"\n ~description:\"Too many recursive calls were needed for unparsing\"\n Data_encoding.empty\n (function Unparsing_too_many_recursive_calls -> Some () | _ -> None)\n (fun () -> Unparsing_too_many_recursive_calls) ;\n (* Unexpected forged value *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.unexpected_forged_value\"\n ~title:\"Unexpected forged value\"\n ~description:\n \"A forged value was encountered but disallowed for that position.\"\n (obj1 (req \"location\" Script.location_encoding))\n (function Unexpected_forged_value loc -> Some loc | _ -> None)\n (fun loc -> Unexpected_forged_value loc) ;\n (* Unexpected ticket *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.unexpected_ticket\"\n ~title:\"Ticket in unauthorized position (type error)\"\n ~description:\"A ticket type has been found\"\n (obj1 (req \"loc\" location_encoding))\n (function Unexpected_ticket loc -> Some loc | _ -> None)\n (fun loc -> Unexpected_ticket loc) ;\n (* Attempt to duplicate a non-dupable type *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.non_dupable_type\"\n ~title:\"Non-dupable type duplication attempt\"\n ~description:\"DUP was used on a non-dupable type (e.g. tickets).\"\n (obj2 (req \"loc\" location_encoding) (req \"type\" Script.expr_encoding))\n (function Non_dupable_type (loc, ty) -> Some (loc, ty) | _ -> None)\n (fun (loc, ty) -> Non_dupable_type (loc, ty)) ;\n (* Unexpected ticket owner*)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.unexpected_ticket_owner\"\n ~title:\"Unexpected ticket owner\"\n ~description:\"Ticket can only be created by a smart contract\"\n (obj1 (req \"ticketer\" Destination.encoding))\n (function Unexpected_ticket_owner t -> Some t | _ -> None)\n (fun t -> Unexpected_ticket_owner t)\n" ;
} ;
{ name = "Ticket_token_unparser" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\n(** [unparse ctxt ex_token] returns the unparsed version of [ex_token] where \n each ticket field is converted to a Micheline representation. The gas is \n being consumed from [ctxt]. *)\nval unparse :\n context ->\n Ticket_token.ex_token ->\n (Ticket_token.unparsed_token * context) tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\n(* TODO: https://gitlab.com/tezos/tezos/-/issues/4167\n\n Disclaimer:\n A more natural place to place [unparse] would be in [Ticket_token] module.\n But unfortunantly, we could not put it there due to circular dependency.\n The root cause of this circular dependency is the dependency\n from [Script_ir_translator] to [Apply_internal_result], but removing this\n dependency would require a relatively large refactor. *)\n\nlet unparse ctxt (Ticket_token.Ex_token {ticketer; contents_type; contents}) =\n let open Lwt_result_syntax in\n let open Script_ir_unparser in\n let* contents, ctxt =\n unparse_comparable_data ctxt Optimized_legacy contents_type contents\n in\n let*? ty_unstripped, ctxt =\n unparse_ty ~loc:Micheline.dummy_location ctxt contents_type\n in\n let*? ctxt = Gas.consume ctxt (Script.strip_annotations_cost ty_unstripped) in\n let ty = Script.strip_annotations ty_unstripped in\n let*? ctxt = Gas.consume ctxt (Script.strip_locations_cost ty) in\n let contents_type = Micheline.strip_locations ty in\n let ticket_token = Ticket_token.{ticketer; contents_type; contents} in\n return (ticket_token, ctxt)\n" ;
} ;
{ name = "Ticket_costs" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module contains constants and utility functions for gas metering\n functions used for extracting and handling tickets for the global ticket\n balance table. *)\n\nmodule Constants : sig\n val cost_collect_tickets_step : Alpha_context.Gas.cost\n\n val cost_compare_ticket_hash : Alpha_context.Gas.cost\n\n val cost_compare_key_contract : Alpha_context.Gas.cost\nend\n\n(** [consume_gas_steps ctxt ~num_steps] consumes gas corresponding to\n a given [num_steps] and [step_cost]. It's useful for paying for gas\n upfront where the number of steps can be determined.\n\n This function is generic and should probably be moved. See issue\n https://gitlab.com/tezos/tezos/-/issues/1950.\n\n *)\nval consume_gas_steps :\n Alpha_context.t ->\n step_cost:Alpha_context.Gas.cost ->\n num_steps:int ->\n Alpha_context.t tzresult\n\n(** [has_tickets_of_ty_cost ty] returns the cost of producing a [has_tickets],\n used internally in the [Ticket_scanner] module. *)\nval has_tickets_of_ty_cost :\n ('a, _) Script_typed_ir.ty -> Saturation_repr.may_saturate Saturation_repr.t\n\n(** [negate_cost z] returns the cost of negating the given value [z]. *)\nval negate_cost : Z.t -> Alpha_context.Gas.cost\n\n(** [add_int_cost n1 n2] returns the cost of adding the values [n1] and [n2]. *)\nval add_int_cost :\n Script_int.n Script_int.num ->\n Script_int.n Script_int.num ->\n Alpha_context.Gas.cost\n\n(** [add_z_cost z1 z2] returns the cost of adding the values [z1] and [z2]. *)\nval add_z_cost : Z.t -> Z.t -> Alpha_context.Gas.cost\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\nmodule S = Saturation_repr\n\nmodule Constants = struct\n let cost_collect_tickets_step = S.safe_int 80\n\n let cost_has_tickets_of_ty type_size =\n S.add (S.safe_int 10) (S.mul (S.safe_int 6) type_size)\n\n let cost_compare_ticket_hash = S.safe_int 10\n\n let cost_compare_key_contract = S.safe_int 10\nend\n\nlet consume_gas_steps ctxt ~step_cost ~num_steps =\n let ( * ) = S.mul in\n if Compare.Int.(num_steps <= 0) then Ok ctxt\n else\n let gas =\n Gas.atomic_step_cost (step_cost * Saturation_repr.safe_int num_steps)\n in\n Gas.consume ctxt gas\n\nlet has_tickets_of_ty_cost ty =\n Constants.cost_has_tickets_of_ty\n Script_typed_ir.(ty_size ty |> Type_size.to_int)\n\n(** Reusing the gas model from [Michelson_v1_gas.Cost_of.neg]\n Approximating 0.066076 x term *)\nlet negate_cost z =\n let size = (7 + Z.numbits z) / 8 in\n Gas.(S.safe_int 25 +@ S.shift_right (S.safe_int size) 4)\n\n(** Reusing the gas model from [Michelson_v1_gas.Cost_of.add] *)\nlet add_int_cost = Michelson_v1_gas.Cost_of.Interpreter.add_int\n\n(** Reusing the gas model from [Michelson_v1_gas.Cost_of.add] *)\nlet add_z_cost z1 z2 =\n add_int_cost (Script_int.of_zint z1) (Script_int.of_zint z2)\n" ;
} ;
{ name = "Ticket_scanner" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module provides an API for extracting tickets of arbitrary types\n from an OCaml values, given a type-witness. *)\n\nopen Alpha_context\n\n(** A type for representing existentially quantified tickets (tickets with\n different types of payloads). An [ex_ticket] value consists of:\n - A type-witness representing the type of the content of the ticket.\n - A ticket value of the particular content type.\n *)\ntype ex_ticket =\n | Ex_ticket :\n 'a Script_typed_ir.comparable_ty * 'a Script_typed_ir.ticket\n -> ex_ticket\n\n(** A type-witness that contains information about which branches of a type ['a]\n include tickets. This value is used for traversing only the relevant\n branches of values when scanning for tickets. *)\ntype 'a has_tickets\n\n(** [type_has_tickets ctxt ty] returns a [has_tickets] witness of the given\n shape [ty].\n *)\nval type_has_tickets :\n context -> ('a, _) Script_typed_ir.ty -> ('a has_tickets * context) tzresult\n\n(** [tickets_of_value ctxt ~include_lazy ht value] extracts all tickets from\n the given [value], using the type-witness [ht]. The [include_lazy] flag\n determines whether or not to traverse lazy structures (values from the context).\n In case the [include_lazy] flag is [true], any big-map contained in the value\n must have an empty overlay or else an error of type\n [Unsupported_non_empty_overlay] is returned. The reason for this restriction\n is that we assume that all lazy big-map diffs should be applied before\n calling this function. Dealing with non-empty overlays would be possible\n in theory, but practically difficult. The challenge is to distinguish\n between overlapping keys between the context and the overlay.\n *)\nval tickets_of_value :\n context ->\n include_lazy:bool ->\n 'a has_tickets ->\n 'a ->\n (ex_ticket list * context) tzresult Lwt.t\n\n(** [tickets_of_node ctxt ~include_lazy ht node] extracts all tickets from\n the given [node], using the type-witness [ht].If [ht] indicates that\n values of the corresponding type may not contain tickets, the node value is\n not parsed. The [include_lazy] flag determines whether or not to traverse\n lazy structures (values from the context). In case the [include_lazy] flag\n is [true], any big-map contained in the value must have an empty overlay or\n else an error of type [Unsupported_non_empty_overlay] is returned. The\n reason for this restriction is that we assume that all lazy big-map diffs\n should be applied before calling this function. Dealing with non-empty\n overlays would be possible in theory, but practically difficult. The\n challenge is to distinguish between overlapping keys between the context and\n the overlay.\n *)\nval tickets_of_node :\n context ->\n include_lazy:bool ->\n 'a has_tickets ->\n Script.node ->\n (ex_ticket list * context) tzresult Lwt.t\n\n(** [has_tickets ht] returns whether or not the type of the given [has_tickets]\n witness [ht] has tickets. *)\nval has_tickets : 'a has_tickets -> bool\n\n(** [ex_ticket_size ctxt ex_ticket] returns the size of the in-memory representation of\n [ex_ticket] in bytes. *)\nval ex_ticket_size :\n context ->\n ex_ticket ->\n (Saturation_repr.may_saturate Saturation_repr.t * context) tzresult Lwt.t\n\n(** [ex_token_and_amount_of_ex_ticket ex_ticket] returns the token and amount of\n the given ticket [ex_ticket]. *)\nval ex_token_and_amount_of_ex_ticket :\n ex_ticket -> Ticket_token.ex_token * Script_typed_ir.ticket_amount\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Trili Tech, <contact@trili.tech> *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\ntype error +=\n | (* Permanent *) Unsupported_non_empty_overlay\n | (* Permanent *) Unsupported_type_operation\n\nlet () =\n register_error_kind\n `Branch\n ~id:\"Unsupported_non_empty_overlay\"\n ~title:\"Unsupported non empty overlay\"\n ~description:\"Unsupported big-map value with non-empty overlay\"\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"Unsupported big-map value with non-empty overlay\")\n Data_encoding.empty\n (function Unsupported_non_empty_overlay -> Some () | _ -> None)\n (fun () -> Unsupported_non_empty_overlay) ;\n register_error_kind\n `Branch\n ~id:\"Unsupported_type_operation\"\n ~title:\"Unsupported type operation\"\n ~description:\"Types embedding operations are not supported\"\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"Types embedding operations are not supported\")\n Data_encoding.empty\n (function Unsupported_type_operation -> Some () | _ -> None)\n (fun () -> Unsupported_type_operation)\n\ntype ex_ticket =\n | Ex_ticket :\n 'a Script_typed_ir.comparable_ty * 'a Script_typed_ir.ticket\n -> ex_ticket\n\nmodule Ticket_inspection = struct\n (* TODO: 1951\n Replace with use of meta-data for ['a ty] type.\n Once ['a ty] values can be extended with custom meta data, this type\n can be removed.\n *)\n (**\n Witness flag for whether a type can be populated by a value containing a\n ticket. [False_ht] must be used only when a value of the type cannot\n contain a ticket.\n\n This flag is necessary for avoiding ticket collection (see below) to have\n quadratic complexity in the order of: size-of-the-type * size-of-value.\n\n This type is local to the [Ticket_scanner] module and should not be\n exported.\n\n *)\n type 'a has_tickets =\n | True_ht : _ Script_typed_ir.ticket has_tickets\n | False_ht : _ has_tickets\n | Pair_ht :\n 'a has_tickets * 'b has_tickets\n -> ('a, 'b) Script_typed_ir.pair has_tickets\n | Union_ht :\n 'a has_tickets * 'b has_tickets\n -> ('a, 'b) Script_typed_ir.union has_tickets\n | Option_ht : 'a has_tickets -> 'a option has_tickets\n | List_ht : 'a has_tickets -> 'a Script_list.t has_tickets\n | Set_ht : 'k has_tickets -> 'k Script_typed_ir.set has_tickets\n | Map_ht :\n 'k has_tickets * 'v has_tickets\n -> ('k, 'v) Script_typed_ir.map has_tickets\n | Big_map_ht :\n 'k has_tickets * 'v has_tickets\n -> ('k, 'v) Script_typed_ir.big_map has_tickets\n\n (* Returns whether or not a comparable type embeds tickets. Currently\n this function returns [false] for all input.\n\n The only reason we keep this code is so that in the future, if tickets were\n ever to be comparable, the compiler would detect a missing pattern match\n case.\n\n Note that in case tickets are made comparable, this function needs to change\n so that constructors like [Union_t] and [Pair_t] are traversed\n recursively.\n *)\n let has_tickets_of_comparable :\n type a ret.\n a Script_typed_ir.comparable_ty -> (a has_tickets -> ret) -> ret =\n fun key_ty k ->\n let open Script_typed_ir in\n match key_ty with\n | Unit_t -> (k [@ocaml.tailcall]) False_ht\n | Never_t -> (k [@ocaml.tailcall]) False_ht\n | Int_t -> (k [@ocaml.tailcall]) False_ht\n | Nat_t -> (k [@ocaml.tailcall]) False_ht\n | Signature_t -> (k [@ocaml.tailcall]) False_ht\n | String_t -> (k [@ocaml.tailcall]) False_ht\n | Bytes_t -> (k [@ocaml.tailcall]) False_ht\n | Mutez_t -> (k [@ocaml.tailcall]) False_ht\n | Bool_t -> (k [@ocaml.tailcall]) False_ht\n | Key_hash_t -> (k [@ocaml.tailcall]) False_ht\n | Key_t -> (k [@ocaml.tailcall]) False_ht\n | Timestamp_t -> (k [@ocaml.tailcall]) False_ht\n | Chain_id_t -> (k [@ocaml.tailcall]) False_ht\n | Address_t -> (k [@ocaml.tailcall]) False_ht\n | Tx_rollup_l2_address_t -> (k [@ocaml.tailcall]) False_ht\n | Pair_t (_, _, _, YesYes) -> (k [@ocaml.tailcall]) False_ht\n | Union_t (_, _, _, YesYes) -> (k [@ocaml.tailcall]) False_ht\n | Option_t (_, _, Yes) -> (k [@ocaml.tailcall]) False_ht\n\n (* Short circuit pairing of two [has_tickets] values.\n If neither left nor right branch contains a ticket, [False_ht] is\n returned. *)\n let pair_has_tickets pair ht1 ht2 =\n match (ht1, ht2) with False_ht, False_ht -> False_ht | _ -> pair ht1 ht2\n\n let map_has_tickets map ht =\n match ht with False_ht -> False_ht | _ -> map ht\n\n type ('a, 'r) continuation = 'a has_tickets -> 'r tzresult\n\n (* Creates a [has_tickets] type-witness value from the given ['a ty].\n The returned value matches the given shape of the [ty] value, except\n it collapses whole branches where no types embed tickets to [False_ht].\n *)\n let rec has_tickets_of_ty :\n type a ac ret.\n (a, ac) Script_typed_ir.ty -> (a, ret) continuation -> ret tzresult =\n fun ty k ->\n let open Script_typed_ir in\n match ty with\n | Ticket_t _ -> (k [@ocaml.tailcall]) True_ht\n | Unit_t -> (k [@ocaml.tailcall]) False_ht\n | Int_t -> (k [@ocaml.tailcall]) False_ht\n | Nat_t -> (k [@ocaml.tailcall]) False_ht\n | Signature_t -> (k [@ocaml.tailcall]) False_ht\n | String_t -> (k [@ocaml.tailcall]) False_ht\n | Bytes_t -> (k [@ocaml.tailcall]) False_ht\n | Mutez_t -> (k [@ocaml.tailcall]) False_ht\n | Key_hash_t -> (k [@ocaml.tailcall]) False_ht\n | Key_t -> (k [@ocaml.tailcall]) False_ht\n | Timestamp_t -> (k [@ocaml.tailcall]) False_ht\n | Address_t -> (k [@ocaml.tailcall]) False_ht\n | Tx_rollup_l2_address_t -> (k [@ocaml.tailcall]) False_ht\n | Bool_t -> (k [@ocaml.tailcall]) False_ht\n | Pair_t (ty1, ty2, _, _) ->\n (has_tickets_of_pair [@ocaml.tailcall])\n ty1\n ty2\n ~pair:(fun ht1 ht2 -> Pair_ht (ht1, ht2))\n k\n | Union_t (ty1, ty2, _, _) ->\n (has_tickets_of_pair [@ocaml.tailcall])\n ty1\n ty2\n ~pair:(fun ht1 ht2 -> Union_ht (ht1, ht2))\n k\n | Lambda_t (_, _, _) ->\n (* As of H, closures cannot contain tickets because APPLY requires\n a packable type and tickets are not packable. *)\n (k [@ocaml.tailcall]) False_ht\n | Option_t (ty, _, _) ->\n (has_tickets_of_ty [@ocaml.tailcall]) ty (fun ht ->\n let opt_hty = map_has_tickets (fun ht -> Option_ht ht) ht in\n (k [@ocaml.tailcall]) opt_hty)\n | List_t (ty, _) ->\n (has_tickets_of_ty [@ocaml.tailcall]) ty (fun ht ->\n let list_hty = map_has_tickets (fun ht -> List_ht ht) ht in\n (k [@ocaml.tailcall]) list_hty)\n | Set_t (key_ty, _) ->\n (has_tickets_of_comparable [@ocaml.tailcall]) key_ty (fun ht ->\n let set_hty = map_has_tickets (fun ht -> Set_ht ht) ht in\n (k [@ocaml.tailcall]) set_hty)\n | Map_t (key_ty, val_ty, _) ->\n (has_tickets_of_key_and_value [@ocaml.tailcall])\n key_ty\n val_ty\n ~pair:(fun ht1 ht2 -> Map_ht (ht1, ht2))\n k\n | Big_map_t (key_ty, val_ty, _) ->\n (has_tickets_of_key_and_value [@ocaml.tailcall])\n key_ty\n val_ty\n ~pair:(fun ht1 ht2 -> Big_map_ht (ht1, ht2))\n k\n | Contract_t _ -> (k [@ocaml.tailcall]) False_ht\n | Sapling_transaction_t _ -> (k [@ocaml.tailcall]) False_ht\n | Sapling_transaction_deprecated_t _ -> (k [@ocaml.tailcall]) False_ht\n | Sapling_state_t _ -> (k [@ocaml.tailcall]) False_ht\n | Operation_t ->\n (* Operations may contain tickets but they should never be passed\n why we fail in this case. *)\n error Unsupported_type_operation\n | Chain_id_t -> (k [@ocaml.tailcall]) False_ht\n | Never_t -> (k [@ocaml.tailcall]) False_ht\n | Bls12_381_g1_t -> (k [@ocaml.tailcall]) False_ht\n | Bls12_381_g2_t -> (k [@ocaml.tailcall]) False_ht\n | Bls12_381_fr_t -> (k [@ocaml.tailcall]) False_ht\n | Chest_t -> (k [@ocaml.tailcall]) False_ht\n | Chest_key_t -> (k [@ocaml.tailcall]) False_ht\n\n and has_tickets_of_pair :\n type a ac b bc c ret.\n (a, ac) Script_typed_ir.ty ->\n (b, bc) Script_typed_ir.ty ->\n pair:(a has_tickets -> b has_tickets -> c has_tickets) ->\n (c, ret) continuation ->\n ret tzresult =\n fun ty1 ty2 ~pair k ->\n (has_tickets_of_ty [@ocaml.tailcall]) ty1 (fun ht1 ->\n (has_tickets_of_ty [@ocaml.tailcall]) ty2 (fun ht2 ->\n (k [@ocaml.tailcall]) (pair_has_tickets pair ht1 ht2)))\n\n and has_tickets_of_key_and_value :\n type k v vc t ret.\n k Script_typed_ir.comparable_ty ->\n (v, vc) Script_typed_ir.ty ->\n pair:(k has_tickets -> v has_tickets -> t has_tickets) ->\n (t, ret) continuation ->\n ret tzresult =\n fun key_ty val_ty ~pair k ->\n (has_tickets_of_comparable [@ocaml.tailcall]) key_ty (fun ht1 ->\n (has_tickets_of_ty [@ocaml.tailcall]) val_ty (fun ht2 ->\n (k [@ocaml.tailcall]) (pair_has_tickets pair ht1 ht2)))\n\n let has_tickets_of_ty ctxt ty =\n Gas.consume ctxt (Ticket_costs.has_tickets_of_ty_cost ty) >>? fun ctxt ->\n has_tickets_of_ty ty ok >|? fun ht -> (ht, ctxt)\nend\n\nmodule Ticket_collection = struct\n let consume_gas_steps =\n Ticket_costs.consume_gas_steps\n ~step_cost:Ticket_costs.Constants.cost_collect_tickets_step\n\n type accumulator = ex_ticket list\n\n type 'a continuation = context -> accumulator -> 'a tzresult Lwt.t\n\n (* Currently this always returns the original list.\n\n If comparables are ever extended to support tickets, this function\n needs to be modified. In particular constructors like [Option] and [Pair]\n would have to recurse on their arguments. *)\n\n let tickets_of_comparable :\n type a ret.\n context ->\n a Script_typed_ir.comparable_ty ->\n accumulator ->\n ret continuation ->\n ret tzresult Lwt.t =\n fun ctxt comp_ty acc k ->\n let open Script_typed_ir in\n match comp_ty with\n | Unit_t -> (k [@ocaml.tailcall]) ctxt acc\n | Never_t -> (k [@ocaml.tailcall]) ctxt acc\n | Int_t -> (k [@ocaml.tailcall]) ctxt acc\n | Nat_t -> (k [@ocaml.tailcall]) ctxt acc\n | Signature_t -> (k [@ocaml.tailcall]) ctxt acc\n | String_t -> (k [@ocaml.tailcall]) ctxt acc\n | Bytes_t -> (k [@ocaml.tailcall]) ctxt acc\n | Mutez_t -> (k [@ocaml.tailcall]) ctxt acc\n | Bool_t -> (k [@ocaml.tailcall]) ctxt acc\n | Key_hash_t -> (k [@ocaml.tailcall]) ctxt acc\n | Key_t -> (k [@ocaml.tailcall]) ctxt acc\n | Timestamp_t -> (k [@ocaml.tailcall]) ctxt acc\n | Chain_id_t -> (k [@ocaml.tailcall]) ctxt acc\n | Address_t -> (k [@ocaml.tailcall]) ctxt acc\n | Tx_rollup_l2_address_t -> (k [@ocaml.tailcall]) ctxt acc\n | Pair_t (_, _, _, YesYes) -> (k [@ocaml.tailcall]) ctxt acc\n | Union_t (_, _, _, YesYes) -> (k [@ocaml.tailcall]) ctxt acc\n | Option_t (_, _, Yes) -> (k [@ocaml.tailcall]) ctxt acc\n\n let tickets_of_set :\n type a ret.\n context ->\n a Script_typed_ir.comparable_ty ->\n a Script_typed_ir.set ->\n accumulator ->\n ret continuation ->\n ret tzresult Lwt.t =\n fun ctxt key_ty _set acc k ->\n consume_gas_steps ctxt ~num_steps:1 >>?= fun ctxt ->\n (* This is only invoked to support any future extensions making tickets\n comparable. *)\n (tickets_of_comparable [@ocaml.tailcall]) ctxt key_ty acc k\n\n let rec tickets_of_value :\n type a ac ret.\n include_lazy:bool ->\n context ->\n a Ticket_inspection.has_tickets ->\n (a, ac) Script_typed_ir.ty ->\n a ->\n accumulator ->\n ret continuation ->\n ret tzresult Lwt.t =\n fun ~include_lazy ctxt hty ty x acc k ->\n let open Script_typed_ir in\n consume_gas_steps ctxt ~num_steps:1 >>?= fun ctxt ->\n match (hty, ty) with\n | False_ht, _ -> (k [@ocaml.tailcall]) ctxt acc\n | Pair_ht (hty1, hty2), Pair_t (ty1, ty2, _, _) ->\n let l, r = x in\n (tickets_of_value [@ocaml.tailcall])\n ~include_lazy\n ctxt\n hty1\n ty1\n l\n acc\n (fun ctxt acc ->\n (tickets_of_value [@ocaml.tailcall])\n ~include_lazy\n ctxt\n hty2\n ty2\n r\n acc\n k)\n | Union_ht (htyl, htyr), Union_t (tyl, tyr, _, _) -> (\n match x with\n | L v ->\n (tickets_of_value [@ocaml.tailcall])\n ~include_lazy\n ctxt\n htyl\n tyl\n v\n acc\n k\n | R v ->\n (tickets_of_value [@ocaml.tailcall])\n ~include_lazy\n ctxt\n htyr\n tyr\n v\n acc\n k)\n | Option_ht el_hty, Option_t (el_ty, _, _) -> (\n match x with\n | Some x ->\n (tickets_of_value [@ocaml.tailcall])\n ~include_lazy\n ctxt\n el_hty\n el_ty\n x\n acc\n k\n | None -> (k [@ocaml.tailcall]) ctxt acc)\n | List_ht el_hty, List_t (el_ty, _) ->\n let elements = Script_list.to_list x in\n (tickets_of_list [@ocaml.tailcall])\n ctxt\n ~include_lazy\n el_hty\n el_ty\n elements\n acc\n k\n | Set_ht _, Set_t (key_ty, _) ->\n (tickets_of_set [@ocaml.tailcall]) ctxt key_ty x acc k\n | Map_ht (_, val_hty), Map_t (key_ty, val_ty, _) ->\n (tickets_of_comparable [@ocaml.tailcall])\n ctxt\n key_ty\n acc\n (fun ctxt acc ->\n (tickets_of_map [@ocaml.tailcall])\n ctxt\n ~include_lazy\n val_hty\n val_ty\n x\n acc\n k)\n | Big_map_ht (_, val_hty), Big_map_t (key_ty, _, _) ->\n if include_lazy then\n (tickets_of_big_map [@ocaml.tailcall]) ctxt val_hty key_ty x acc k\n else (k [@ocaml.tailcall]) ctxt acc\n | True_ht, Ticket_t (comp_ty, _) ->\n (k [@ocaml.tailcall]) ctxt (Ex_ticket (comp_ty, x) :: acc)\n\n and tickets_of_list :\n type a ac ret.\n context ->\n include_lazy:bool ->\n a Ticket_inspection.has_tickets ->\n (a, ac) Script_typed_ir.ty ->\n a list ->\n accumulator ->\n ret continuation ->\n ret tzresult Lwt.t =\n fun ctxt ~include_lazy el_hty el_ty elements acc k ->\n consume_gas_steps ctxt ~num_steps:1 >>?= fun ctxt ->\n match elements with\n | elem :: elems ->\n (tickets_of_value [@ocaml.tailcall])\n ~include_lazy\n ctxt\n el_hty\n el_ty\n elem\n acc\n (fun ctxt acc ->\n (tickets_of_list [@ocaml.tailcall])\n ~include_lazy\n ctxt\n el_hty\n el_ty\n elems\n acc\n k)\n | [] -> (k [@ocaml.tailcall]) ctxt acc\n\n and tickets_of_map :\n type k v vc ret.\n include_lazy:bool ->\n context ->\n v Ticket_inspection.has_tickets ->\n (v, vc) Script_typed_ir.ty ->\n (k, v) Script_typed_ir.map ->\n accumulator ->\n ret continuation ->\n ret tzresult Lwt.t =\n fun ~include_lazy ctxt val_hty val_ty map acc k ->\n let (module M) = Script_map.get_module map in\n consume_gas_steps ctxt ~num_steps:1 >>?= fun ctxt ->\n (* Pay gas for folding over the values *)\n consume_gas_steps ctxt ~num_steps:M.size >>?= fun ctxt ->\n let values = M.OPS.fold (fun _ v vs -> v :: vs) M.boxed [] in\n (tickets_of_list [@ocaml.tailcall])\n ~include_lazy\n ctxt\n val_hty\n val_ty\n values\n acc\n k\n\n and tickets_of_big_map :\n type k v ret.\n context ->\n v Ticket_inspection.has_tickets ->\n k Script_typed_ir.comparable_ty ->\n (k, v) Script_typed_ir.big_map ->\n accumulator ->\n ret continuation ->\n ret tzresult Lwt.t =\n fun ctxt\n val_hty\n key_ty\n (Big_map {id; diff = {map = _; size}; key_type = _; value_type})\n acc\n k ->\n consume_gas_steps ctxt ~num_steps:1 >>?= fun ctxt ->\n (* Require empty overlay *)\n if Compare.Int.(size > 0) then tzfail Unsupported_non_empty_overlay\n else\n (* Traverse the keys for tickets, although currently keys should never\n contain any tickets. *)\n (tickets_of_comparable [@ocaml.tailcall]) ctxt key_ty acc (fun ctxt acc ->\n (* Accumulate tickets from values of the big-map stored in the context *)\n match id with\n | Some id ->\n let accum (values, ctxt) (_key_hash, exp) =\n Script_ir_translator.parse_data\n ~elab_conf:Script_ir_translator_config.(make ~legacy:true ())\n ctxt\n ~allow_forged:true\n value_type\n (Micheline.root exp)\n >|=? fun (v, ctxt) -> (v :: values, ctxt)\n in\n Big_map.list_key_values ctxt id >>=? fun (ctxt, exps) ->\n List.fold_left_es accum ([], ctxt) exps >>=? fun (values, ctxt) ->\n (tickets_of_list [@ocaml.tailcall])\n ~include_lazy:true\n ctxt\n val_hty\n value_type\n values\n acc\n k\n | None -> (k [@ocaml.tailcall]) ctxt acc)\n\n let tickets_of_value ctxt ~include_lazy ht ty x =\n tickets_of_value ctxt ~include_lazy ht ty x [] (fun ctxt ex_tickets ->\n return (ex_tickets, ctxt))\nend\n\ntype 'a has_tickets =\n | Has_tickets :\n 'a Ticket_inspection.has_tickets * ('a, _) Script_typed_ir.ty\n -> 'a has_tickets\n\nlet type_has_tickets ctxt ty =\n Ticket_inspection.has_tickets_of_ty ctxt ty >|? fun (has_tickets, ctxt) ->\n (Has_tickets (has_tickets, ty), ctxt)\n\nlet tickets_of_value ctxt ~include_lazy (Has_tickets (ht, ty)) =\n Ticket_collection.tickets_of_value ctxt ~include_lazy ht ty\n\nlet has_tickets (Has_tickets (ht, _)) =\n match ht with Ticket_inspection.False_ht -> false | _ -> true\n\nlet tickets_of_node ctxt ~include_lazy has_tickets expr =\n let (Has_tickets (ht, ty)) = has_tickets in\n match ht with\n | Ticket_inspection.False_ht -> return ([], ctxt)\n | _ ->\n Script_ir_translator.parse_data\n ctxt\n ~elab_conf:Script_ir_translator_config.(make ~legacy:true ())\n ~allow_forged:true\n ty\n expr\n >>=? fun (value, ctxt) ->\n tickets_of_value ctxt ~include_lazy has_tickets value\n\nlet ex_ticket_size ctxt (Ex_ticket (ty, ticket)) =\n (* type *)\n Script_typed_ir.ticket_t Micheline.dummy_location ty >>?= fun ty ->\n Script_ir_unparser.unparse_ty ~loc:() ctxt ty >>?= fun (ty', ctxt) ->\n let ty_nodes, ty_size = Script_typed_ir_size.node_size ty' in\n let ty_size_cost = Script_typed_ir_size_costs.nodes_cost ~nodes:ty_nodes in\n Gas.consume ctxt ty_size_cost >>?= fun ctxt ->\n (* contents *)\n let val_nodes, val_size = Script_typed_ir_size.value_size ty ticket in\n let val_size_cost = Script_typed_ir_size_costs.nodes_cost ~nodes:val_nodes in\n Gas.consume ctxt val_size_cost >>?= fun ctxt ->\n (* gas *)\n return (Saturation_repr.add ty_size val_size, ctxt)\n\nlet ex_token_and_amount_of_ex_ticket\n (Ex_ticket (contents_type, {Script_typed_ir.ticketer; contents; amount})) =\n (Ticket_token.Ex_token {ticketer; contents_type; contents}, amount)\n" ;
} ;
{ name = "Ticket_balance_key" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\n(** This module exposes a function for generating a ticket-balance key-hash\n given an owner and a ticket-token. The key-hash is used for populating the\n global ticket-balance table that tracks ownership of tickets for different tokens.\n *)\n\n(** [make ~owner ~ticketer ~contents_type ~contents] returns [key_hash] of the\n given [owner], [ticketer], [contents_type] and [contents]. Note that the\n [location] of the [Script.node] values [contents_type] and [contents] are\n irrelevant since [Ticket_hash.make] will strip the locations before calculating the hash. *)\nval make :\n context ->\n owner:Destination.t ->\n ticketer:Contract.t ->\n contents_type:Script.node ->\n contents:Script.node ->\n (Ticket_hash.t * context) tzresult Lwt.t\n\n(** [of_ex_token ctxt ~owner ex_token] returns the [key_hash] of the\n given [owner] and [ex_token]. *)\nval of_ex_token :\n context ->\n owner:Destination.t ->\n Ticket_token.ex_token ->\n (Ticket_hash.t * context) tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Trili Tech, <contact@trili.tech> *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\nlet make ctxt ~owner ~ticketer ~contents_type ~contents =\n let open Lwt_result_syntax in\n let ticketer_address =\n Script_typed_ir.\n {destination = Contract ticketer; entrypoint = Entrypoint.default}\n in\n let owner_address =\n Script_typed_ir.{destination = owner; entrypoint = Entrypoint.default}\n in\n let* ticketer, ctxt =\n Script_ir_translator.unparse_data\n ctxt\n Script_ir_unparser.Optimized_legacy\n Script_typed_ir.address_t\n ticketer_address\n in\n let* owner, ctxt =\n Script_ir_translator.unparse_data\n ctxt\n Script_ir_unparser.Optimized_legacy\n Script_typed_ir.address_t\n owner_address\n in\n Lwt.return\n @@ Ticket_hash.make\n ctxt\n ~ticketer:(Micheline.root ticketer)\n ~ty:contents_type\n ~contents\n ~owner:(Micheline.root owner)\n\n(* This function extracts nodes of:\n - Ticketer\n - Type of content\n - Content\n - Owner\n to generate at ticket-balance key-hash.*)\nlet of_ex_token ctxt ~owner\n (Ticket_token.Ex_token {ticketer; contents_type; contents}) =\n let loc = Micheline.dummy_location in\n Script_ir_unparser.unparse_ty ~loc ctxt contents_type\n >>?= fun (cont_ty_unstripped, ctxt) ->\n (* We strip the annotations from the content type in order to map\n tickets with the same content type, but with different annotations, to the\n same hash. *)\n Gas.consume ctxt (Script.strip_annotations_cost cont_ty_unstripped)\n >>?= fun ctxt ->\n let ty = Script.strip_annotations cont_ty_unstripped in\n Script_ir_unparser.unparse_comparable_data\n ctxt\n Script_ir_unparser.Optimized_legacy\n contents_type\n contents\n >>=? fun (contents, ctxt) ->\n make\n ctxt\n ~owner\n ~ticketer\n ~contents_type:ty\n ~contents:(Micheline.root contents)\n" ;
} ;
{ name = "Ticket_lazy_storage_diff" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** [ticket_diffs_of_lazy_storage_diff ctxt diffs] returns a list of ticket-token\n balance differences, given a list, [diffs], of lazy storage diff items.\n *)\nval ticket_diffs_of_lazy_storage_diff :\n Alpha_context.context ->\n Alpha_context.Lazy_storage.diffs_item list ->\n ((Ticket_token.ex_token * Z.t) list * Alpha_context.context) tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\ntype error += Failed_to_load_big_map_value_type of Big_map.Id.t\n\nlet () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"Failed_to_load_big_map_value_type\"\n ~title:\"Failed to load big-map value type\"\n ~description:\n \"Failed to load big-map value type when computing ticket diffs.\"\n ~pp:(fun ppf big_map_id ->\n Format.fprintf\n ppf\n \"Failed to load big-map value type for big-map-id: '%a'\"\n Z.pp_print\n (Big_map.Id.unparse_to_z big_map_id))\n (obj1 (req \"big_map_id\" Big_map.Id.encoding))\n (function\n | Failed_to_load_big_map_value_type big_map_id -> Some big_map_id\n | _ -> None)\n (fun big_map_id -> Failed_to_load_big_map_value_type big_map_id)\n\n(** Extracts the ticket-token and amount from an ex_ticket value. *)\nlet token_and_amount ctxt ex_ticket =\n Gas.consume ctxt Ticket_costs.Constants.cost_collect_tickets_step\n >|? fun ctxt ->\n let token, amount =\n Ticket_scanner.ex_token_and_amount_of_ex_ticket ex_ticket\n in\n ((token, Script_int.(to_zint (amount :> n num))), ctxt)\n\n(** Extracts the ticket-token and amount from an ex_ticket value and returns\n the opposite of the amount. This is used to account for removal of tickets inside\n big maps when either a ticket is taken out of a big map or a whole big map is\n dropped. *)\nlet neg_token_and_amount ctxt ex_ticket =\n token_and_amount ctxt ex_ticket >>? fun ((token, amount), ctxt) ->\n Gas.consume ctxt (Ticket_costs.negate_cost amount) >|? fun ctxt ->\n ((token, Z.neg amount), ctxt)\n\nlet parse_value_type ctxt value_type =\n Script_ir_translator.parse_big_map_value_ty\n ctxt\n ~legacy:true\n (Micheline.root value_type)\n\n(** Collects all ticket-token balances contained in the given node and prepends\n them to the accumulator [acc]. The given [get_token_and_amount] function\n extracts the ticket-token and amount (either positive or negative) from an\n [ex_ticket] value, depending on whether the diff stems from adding or\n removing a value containing tickets. *)\nlet collect_token_diffs_of_node ctxt has_tickets node ~get_token_and_amount acc\n =\n Ticket_scanner.tickets_of_node\n ctxt\n (* It's currently not possible to have nested lazy structures, but this is\n for future proofing. *)\n ~include_lazy:true\n has_tickets\n (Micheline.root node)\n >>=? fun (ex_tickets, ctxt) ->\n List.fold_left_e\n (fun (acc, ctxt) ticket ->\n get_token_and_amount ctxt ticket >|? fun (item, ctxt) ->\n (item :: acc, ctxt))\n (acc, ctxt)\n ex_tickets\n >>?= return\n\n(** A module for keeping track of script-key-hashes. It's used for looking up\n keys for multiple big-map updates referencing the same key.\n *)\n\nmodule Key_hash_map =\n Carbonated_map.Make\n (struct\n type context = Alpha_context.context\n\n let consume = Alpha_context.Gas.consume\n end)\n (struct\n type t = Script_expr_hash.t\n\n let compare = Script_expr_hash.compare\n\n let compare_cost _ = Ticket_costs.Constants.cost_compare_ticket_hash\n end)\n\n(** Collects all ticket-token diffs from a big-map update and prepends them\n to the accumulator [acc]. *)\nlet collect_token_diffs_of_big_map_update ctxt ~big_map_id has_tickets\n {Lazy_storage_kind.Big_map.key = _; key_hash; value} already_updated acc =\n let collect_token_diffs_of_node_option ctxt ~get_token_and_amount expr_opt acc\n =\n match expr_opt with\n | Some expr ->\n collect_token_diffs_of_node\n ctxt\n has_tickets\n expr\n ~get_token_and_amount\n acc\n | None -> return (acc, ctxt)\n in\n (* First check if the key-hash has already been updated, in that case pull the\n value from the [already_updated] map. Note that this should not happen with\n the current implementation of big-map overlays as it guarantees that keys\n are unique. The extra check is used for future proofing.\n *)\n ( Key_hash_map.find ctxt key_hash already_updated >>?= fun (val_opt, ctxt) ->\n match val_opt with\n | Some updated_value -> return (updated_value, ctxt)\n | None ->\n (* Load tickets from the old value that was removed. *)\n Big_map.get_opt ctxt big_map_id key_hash >|=? fun (ctxt, old_value) ->\n (old_value, ctxt) )\n >>=? fun (old_value, ctxt) ->\n collect_token_diffs_of_node_option\n ctxt\n ~get_token_and_amount:neg_token_and_amount\n old_value\n acc\n >>=? fun (acc, ctxt) ->\n Key_hash_map.update\n ctxt\n key_hash\n (fun ctxt _ -> ok (Some value, ctxt))\n already_updated\n >>?= fun (already_updated, ctxt) ->\n (* TODO: #2303\n Avoid re-parsing the value.\n In order to find tickets from the new value, we need to parse it. It would\n be more efficient if the value was already present.\n *)\n collect_token_diffs_of_node_option\n ctxt\n ~get_token_and_amount:token_and_amount\n value\n acc\n >|=? fun (tickets, ctxt) -> (tickets, already_updated, ctxt)\n\n(** Collects all ticket-token diffs from a list of big-map updates and prepends\n them to the accumulator [acc]. *)\nlet collect_token_diffs_of_big_map_updates ctxt big_map_id ~value_type updates\n acc =\n (* TODO: #2303\n Avoid re-parsing the value type.\n We should have the non-serialized version of the value type.\n *)\n parse_value_type ctxt value_type\n >>?= fun (Script_typed_ir.Ex_ty value_type, ctxt) ->\n Ticket_scanner.type_has_tickets ctxt value_type\n >>?= fun (has_tickets, ctxt) ->\n List.fold_left_es\n (fun (acc, already_updated, ctxt) update ->\n collect_token_diffs_of_big_map_update\n ctxt\n ~big_map_id\n has_tickets\n update\n already_updated\n acc)\n (acc, Key_hash_map.empty, ctxt)\n updates\n >|=? fun (acc, _already_updated, ctxt) -> (acc, ctxt)\n\n(** Given a big-map id, this function collects ticket-token diffs and prepends\n them to the accumulator [acc]. *)\nlet collect_token_diffs_of_big_map ctxt ~get_token_and_amount big_map_id acc =\n Gas.consume ctxt Ticket_costs.Constants.cost_collect_tickets_step\n >>?= fun ctxt ->\n Big_map.exists ctxt big_map_id >>=? fun (ctxt, key_val_tys) ->\n match key_val_tys with\n | Some (_key_ty, value_ty) ->\n (* TODO: #2303\n Avoid re-parsing the value type.\n In order to find tickets from the value, we need to parse the value\n type. It would be more efficient if the value preserved.\n *)\n parse_value_type ctxt value_ty\n >>?= fun (Script_typed_ir.Ex_ty value_type, ctxt) ->\n Ticket_scanner.type_has_tickets ctxt value_type\n >>?= fun (has_tickets, ctxt) ->\n (* Iterate over big-map items. *)\n Big_map.list_key_values ctxt big_map_id >>=? fun (ctxt, exprs) ->\n List.fold_left_es\n (fun (acc, ctxt) (_key_hash, node) ->\n collect_token_diffs_of_node\n ctxt\n has_tickets\n node\n ~get_token_and_amount\n acc)\n (acc, ctxt)\n exprs\n | None -> tzfail (Failed_to_load_big_map_value_type big_map_id)\n\n(** Collects ticket-token diffs from a big-map and a list of updates, and\n prepends them to the given accumulator [acc]. *)\nlet collect_token_diffs_of_big_map_and_updates ctxt big_map_id updates acc =\n Gas.consume ctxt Ticket_costs.Constants.cost_collect_tickets_step\n >>?= fun ctxt ->\n Big_map.exists ctxt big_map_id >>=? fun (ctxt, key_val_opt) ->\n match key_val_opt with\n | Some (_val, value_type) ->\n collect_token_diffs_of_big_map_updates\n ctxt\n big_map_id\n ~value_type\n updates\n acc\n | None -> tzfail (Failed_to_load_big_map_value_type big_map_id)\n\n(** Inspects the given [Lazy_storage.diffs_item] and prepends all ticket-token\n diffs, resulting from the updates, to the given accumulator [acc]. *)\nlet collect_token_diffs_of_big_map_diff ctxt diff_item acc =\n Gas.consume ctxt Ticket_costs.Constants.cost_collect_tickets_step\n >>?= fun ctxt ->\n match diff_item with\n | Lazy_storage.Item (Lazy_storage_kind.Big_map, big_map_id, Remove) ->\n (* Collect all removed tokens from the big-map. *)\n collect_token_diffs_of_big_map\n ctxt\n ~get_token_and_amount:neg_token_and_amount\n big_map_id\n acc\n | Item (Lazy_storage_kind.Big_map, big_map_id, Update {init; updates}) -> (\n match init with\n | Lazy_storage.Existing ->\n (* Collect token diffs from the updates to the big-map. *)\n collect_token_diffs_of_big_map_and_updates ctxt big_map_id updates acc\n | Copy {src} ->\n (* Collect tokens diffs from the source of the copied big-map. *)\n collect_token_diffs_of_big_map\n ctxt\n ~get_token_and_amount:token_and_amount\n src\n acc\n >>=? fun (acc, ctxt) ->\n (* Collect token diffs from the updates to the copied big-map. *)\n collect_token_diffs_of_big_map_and_updates ctxt src updates acc\n | Alloc {key_type = _; value_type} ->\n collect_token_diffs_of_big_map_updates\n ctxt\n big_map_id\n ~value_type\n updates\n acc)\n | Item (Sapling_state, _, _) -> return (acc, ctxt)\n\nlet ticket_diffs_of_lazy_storage_diff ctxt diffs_items =\n List.fold_left_es\n (fun (acc, ctxt) diff_item ->\n collect_token_diffs_of_big_map_diff ctxt diff_item acc)\n ([], ctxt)\n diffs_items\n" ;
} ;
{ name = "Tx_rollup_parameters" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxheadalpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** A module for representing and extracting typed transactional rollup\n parameters. *)\n\nopen Script_typed_ir\n\n(** A type representing deposit parameters for transactional rollups. Deposit\n parameters consist of a ticket of arbitrary content along with a\n layer-2 destination address. *)\ntype deposit_parameters = {\n ex_ticket : Ticket_scanner.ex_ticket;\n l2_destination : tx_rollup_l2_address;\n}\n\n(** [get_deposit_parameters ty value] returns [ex_ticket] and a\n [tx_rollup_l2_address] from a michelson typed value.\n\n This function is intended to be used to enforce the type of the transaction\n to a [tx_rollup%deposit]. It must be used both in [ticket_diffs_of_operations]\n to account for the ticket deposited and in [apply] to retrieve the ticket\n when applying the transaction to a tx_rollup. *)\nval get_deposit_parameters :\n (('a ticket, tx_rollup_l2_address) pair, 'comparable) ty ->\n ('a ticket, tx_rollup_l2_address) pair ->\n deposit_parameters\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Oxhead Alpha <info@oxheadalpha.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Script_typed_ir\n\ntype deposit_parameters = {\n ex_ticket : Ticket_scanner.ex_ticket;\n l2_destination : tx_rollup_l2_address;\n}\n\nlet get_deposit_parameters :\n type a comparable.\n ((a ticket, tx_rollup_l2_address) pair, comparable) ty ->\n (a ticket, tx_rollup_l2_address) pair ->\n deposit_parameters =\n fun (Pair_t (Ticket_t (ty, _), Tx_rollup_l2_address_t, _, _))\n (ticket, l2_destination) ->\n {ex_ticket = Ticket_scanner.Ex_ticket (ty, ticket); l2_destination}\n" ;
} ;
{ name = "Zk_rollup_parameters" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** A module for representing and extracting typed ZK rollup\n parameters. *)\n\n(** A type representing deposit parameters for ZK rollups. Deposit\n parameters consist of a ticket of arbitrary content along with a\n layer-2 ZKRU operation byte representation. *)\ntype deposit_parameters = {\n ex_ticket : Ticket_scanner.ex_ticket;\n zkru_operation : Alpha_context.Zk_rollup.Operation.t;\n}\n\n(** [get_deposit_parameters ty value] returns [ex_ticket] and a\n [zkru_operation] from a michelson typed value. if [ty] is not of a\n pair of ticket and [bytes] then it fails with\n [Zk_rollup_errors.Wrong_deposit_parameters].\n\n This function is intended to be used to enforce the type of the transaction\n to a [zk_rollup%deposit]. It must be used both in [ticket_diffs_of_operations]\n to account for the ticket deposited and in [apply] to retrieve the ticket\n when applying the transaction to a zk_rollup. *)\nval get_deposit_parameters :\n ( ('a Script_typed_ir.ticket, bytes) Script_typed_ir.pair,\n 'comparable )\n Script_typed_ir.ty ->\n ('a Script_typed_ir.ticket, bytes) Script_typed_ir.pair ->\n deposit_parameters tzresult\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\ntype deposit_parameters = {\n ex_ticket : Ticket_scanner.ex_ticket;\n zkru_operation : Alpha_context.Zk_rollup.Operation.t;\n}\n\nlet get_deposit_parameters :\n type a comparable.\n ( (a Script_typed_ir.ticket, bytes) Script_typed_ir.pair,\n comparable )\n Script_typed_ir.ty ->\n (a Script_typed_ir.ticket, bytes) Script_typed_ir.pair ->\n deposit_parameters tzresult =\n fun ty contents ->\n let open Script_typed_ir in\n match (ty, contents) with\n | Pair_t (Ticket_t (ty, _), Bytes_t, _, _), (ticket, op_bytes) -> (\n match\n Data_encoding.Binary.of_bytes_opt\n Alpha_context.Zk_rollup.Operation.encoding\n op_bytes\n with\n | None -> error Alpha_context.Zk_rollup.Errors.Wrong_deposit_parameters\n | Some zkru_operation ->\n ok {ex_ticket = Ticket_scanner.Ex_ticket (ty, ticket); zkru_operation}\n )\n" ;
} ;
{ name = "Ticket_token_map" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\n(** A module exposing a carbonated map where keys are [Ticket_token.ex_token]\n values. *)\n\n(** A map where keys are [Ticket_token.ex_token] values. *)\ntype 'a t\n\n(** [empty] is a map without any elements. *)\nval empty : 'a t\n\n(** [update ctxt k f map] updates or adds the value of the key [k] using [f].\n The function accounts for the gas cost for finding the element. [f] must\n account for its own gas costs. *)\nval update :\n context ->\n Ticket_token.ex_token ->\n (context -> 'a option -> ('a option * context) tzresult) ->\n 'a t ->\n ('a t * context) tzresult Lwt.t\n\n(** [fold_e ctxt f z m] folds over the map [m] using the initial value [z] and\n the accumulator function [f]. [f] must account for its own gas costs. *)\nval fold_e :\n context ->\n (context ->\n 'state ->\n Ticket_token.ex_token ->\n 'a ->\n ('state * context) tzresult) ->\n 'state ->\n 'a t ->\n ('state * context) tzresult\n\n(** Lwt-aware variant of {!fold_e}. *)\nval fold_es :\n context ->\n (context ->\n 'state ->\n Ticket_token.ex_token ->\n 'a ->\n ('state * context) tzresult Lwt.t) ->\n 'state ->\n 'a t ->\n ('state * context) tzresult Lwt.t\n\n(** [find ctxt k m] looks up the value with key [k] in the given map [m] and\n also accounts for the gas cost of finding the key. *)\nval find :\n context ->\n Ticket_token.ex_token ->\n 'a t ->\n ('a option * context) tzresult Lwt.t\n\n(** [of_list ctxt ~merge_overlaps m] creates a map from a list of key-value\n pairs. In case there are overlapping keys, their values are combined\n using the [merge_overlap] function. The function accounts for gas for\n traversing the elements. [merge_overlap] should account for its own gas\n cost. *)\nval of_list :\n context ->\n merge_overlap:(context -> 'a -> 'a -> ('a * context, error trace) result) ->\n (Ticket_token.ex_token * 'a) list ->\n ('a t * context) tzresult Lwt.t\n\n(** [to_list m] transforms a map [m] into a list. It also accounts for the gas\n cost for traversing the elements. *)\nval to_list :\n context -> 'a t -> ((Ticket_token.ex_token * 'a) list * context) tzresult\n\n(** [map_e ctxt f m] maps over all key-value pairs in the map [m] using the\n function [f]. It accounts for gas costs associated with traversing the\n elements. [f] must account for its own gas cost. *)\nval map_e :\n context ->\n (context -> Ticket_token.ex_token -> 'a -> ('b * context) tzresult) ->\n 'a t ->\n ('b t * context) tzresult\n\n(** [merge ctxt ~merge_overlap m1 m2] merges the maps [m1] and [m2]. In case\n there are overlapping keys, their values are combined using the\n [merge_overlap] function. Gas costs for traversing all elements from both\n maps are accounted for. [merge_overlap] must account for its own gas\n costs. *)\nval merge :\n context ->\n merge_overlap:(context -> 'a -> 'a -> ('a * context) tzresult) ->\n 'a t ->\n 'a t ->\n ('a t * context) tzresult\n\n(** [to_ticket_receipt ctxt ~owner t] converts a ticket token map into a ticket receipt.\n It also accounts for the gas cost for traversing map and unparsing the elements. *)\nval to_ticket_receipt :\n context ->\n owner:Destination.t ->\n Z.t t ->\n (Ticket_receipt.t * context) tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\n(** A carbonated map where the keys are [Ticket_hash.t] values. *)\nmodule Ticket_token_map =\n Carbonated_map.Make\n (struct\n type context = Alpha_context.context\n\n let consume = Gas.consume\n end)\n (struct\n type t = Ticket_hash.t\n\n let compare = Ticket_hash.compare\n\n let compare_cost _ = Ticket_costs.Constants.cost_compare_ticket_hash\n end)\n\n(** Conceptually a map from [Ticket_token.ex_token] to values. Since\n ticket-tokens are expensive to compare we use [Ticket_hash.t] keys instead,\n and store the ticket-token along with the value. *)\ntype 'a t = (Ticket_token.ex_token * 'a) Ticket_token_map.t\n\nlet empty = Ticket_token_map.empty\n\nlet key_of_ticket_token ctxt (Ticket_token.Ex_token {ticketer; _} as token) =\n (* We use the [ticket_balance_key] function for generating a key-hash\n for comparing tokens. Since an owner contract is required we use [ticketer]\n but any dummy value would work as long as it's consistent.\n *)\n Ticket_balance_key.of_ex_token\n ctxt\n ~owner:(Destination.Contract ticketer)\n token\n\nlet update ctxt key f m =\n key_of_ticket_token ctxt key >>=? fun (key_hash, ctxt) ->\n let f ctxt val_opt =\n (match val_opt with\n | Some (_tkn, value) -> f ctxt (Some value)\n | None -> f ctxt None)\n >|? fun (val_opt, ctxt) -> (Option.map (fun v -> (key, v)) val_opt, ctxt)\n in\n Ticket_token_map.update ctxt key_hash f m |> Lwt.return\n\nlet fold_e ctxt f =\n Ticket_token_map.fold_e ctxt (fun ctxt acc _key_hash (tkn, value) ->\n f ctxt acc tkn value)\n\nlet fold_es ctxt f =\n Ticket_token_map.fold_es ctxt (fun ctxt acc _key_hash (tkn, value) ->\n f ctxt acc tkn value)\n\nlet find ctxt ticket_token map =\n key_of_ticket_token ctxt ticket_token >>=? fun (key_hash, ctxt) ->\n Ticket_token_map.find ctxt key_hash map >>?= fun (val_opt, ctxt) ->\n return (Option.map snd val_opt, ctxt)\n\nlet lift_merge_overlap merge_overlap ctxt (tkn1, v1) (_tkn2, v2) =\n merge_overlap ctxt v1 v2 >|? fun (v, ctxt) -> ((tkn1, v), ctxt)\n\nlet of_list ctxt ~merge_overlap token_values =\n List.fold_left_es\n (fun (map, ctxt) (token, value) ->\n key_of_ticket_token ctxt token >>=? fun (key_hash, ctxt) ->\n Lwt.return\n (Ticket_token_map.update\n ctxt\n key_hash\n (fun ctxt old_val ->\n match old_val with\n | None -> ok (Some (token, value), ctxt)\n | Some old ->\n lift_merge_overlap merge_overlap ctxt old (token, value)\n >|? fun (x, ctxt) -> (Some x, ctxt))\n map))\n (Ticket_token_map.empty, ctxt)\n token_values\n\nlet map_e ctxt f =\n Ticket_token_map.map_e ctxt (fun ctxt _key (tkn, value) ->\n f ctxt tkn value >|? fun (new_value, ctxt) -> ((tkn, new_value), ctxt))\n\nlet to_list ctxt map =\n Ticket_token_map.to_list ctxt map >>? fun (list, ctxt) ->\n (* Consume gas for traversing the list again and remove the key-hash. *)\n Gas.consume\n ctxt\n (Carbonated_map_costs.fold_cost ~size:(Ticket_token_map.size map))\n >|? fun ctxt -> (List.map snd list, ctxt)\n\nlet merge ctxt ~merge_overlap =\n Ticket_token_map.merge ctxt ~merge_overlap:(lift_merge_overlap merge_overlap)\n\nlet to_ticket_receipt ctxt ~owner ticket_token_map =\n let open Lwt_result_syntax in\n Ticket_token_map.fold_es\n ctxt\n (fun ctxt acc _ticket_hash (ex_ticket, amount) ->\n if Z.(equal amount zero) then return (acc, ctxt)\n else\n let* ticket_token, ctxt =\n Ticket_token_unparser.unparse ctxt ex_ticket\n in\n let update =\n Ticket_receipt.{ticket_token; updates = [{account = owner; amount}]}\n in\n return (update :: acc, ctxt))\n []\n ticket_token_map\n" ;
} ;
{ name = "Ticket_operations_diff" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** A module that provides functionality for extracting ticket-token differences\n from a list of operations. *)\n\n(** A type representing ticket-token balance differences. Each value consists\n of:\n - [ticket_token] - the type of the ticket.\n - [total_amount] - the total amount of transferred ticket-tokens.\n - [destinations] - a list of amount and contract pairs.\n Invariant: [total_amount] is the sum of the amounts in [destinations]. *)\ntype ticket_token_diff = private {\n ticket_token : Ticket_token.ex_token;\n total_amount : Script_int.n Script_int.num;\n destinations :\n (Alpha_context.Destination.t * Script_typed_ir.ticket_amount) list;\n}\n\n(** [ticket_diffs_of_operations ctxt ops] returns a\n list of ticket-tokens diffs given a context, [ctxt], and list of packed\n operations, [ops]. The diffs result from either a [Transaction] operation\n with parameters containing tickets, or an [Origination] operation with the\n initial storage containing tickets.\n\n Tickets with amount zero are *not* allowed. If a zero-amount ticket is\n encountered, a {!Ticket_scanner.Forbidden_zero_ticket_quantity} error is\n returned. *)\nval ticket_diffs_of_operations :\n Alpha_context.context ->\n Script_typed_ir.packed_internal_operation list ->\n (ticket_token_diff list * Alpha_context.context) tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\ntype ticket_transfer = {\n destination : Destination.t;\n tickets : Ticket_scanner.ex_ticket list;\n}\n\ntype ticket_token_diff = {\n ticket_token : Ticket_token.ex_token;\n total_amount : Script_int.n Script_int.num;\n destinations : (Destination.t * Ticket_amount.t) list;\n}\n\ntype error += Failed_to_get_script of Contract.t | Contract_not_originated\n\nlet () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"Failed_to_get_script\"\n ~title:\"Failed to get script for contract\"\n ~description:\n \"Failed to get script for contract when scanning operations for tickets\"\n ~pp:(fun ppf contract ->\n Format.fprintf\n ppf\n \"Failed to get script for contract %a\"\n Contract.pp\n contract)\n (obj1 (req \"contract\" Contract.encoding))\n (function Failed_to_get_script c -> Some c | _ -> None)\n (fun c -> Failed_to_get_script c) ;\n register_error_kind\n `Permanent\n ~id:\"contract_not_originated\"\n ~title:\"Contract not originated\"\n ~description:\"Non originated contract detected in ticket update.\"\n ~pp:(fun ppf () -> Format.fprintf ppf \"Contract was not pre-originated\")\n unit\n (function Contract_not_originated -> Some () | _ -> None)\n (fun () -> Contract_not_originated)\n\n(** A carbonated map where the keys are destination (contract or tx_rollup). *)\nmodule Destination_map =\n Carbonated_map.Make\n (struct\n type context = Alpha_context.context\n\n let consume = Alpha_context.Gas.consume\n end)\n (struct\n type t = Destination.t\n\n let compare = Destination.compare\n\n (* TODO: #2667\n Change cost-function to one for comparing destinations.\n Not expected to have any performance impact but we should update for\n completeness.\n *)\n let compare_cost _ = Ticket_costs.Constants.cost_compare_key_contract\n end)\n\n(** A module for mapping ticket-tokens to a map of contract destinations and\n amounts. The values specify how to distribute the spending of a ticket-token\n across different contracts.\n\n In the example below, there is a total of 4 Token1 ticket-tokens\n transferred: three units are sent to contract K1 and one unit to K2.\n Additionally, there are 12 units of Token2 sent to K2, K7 and K8. And one\n unit of Token3 sent to K1.\n {\n Token1 -> { K1 -> 3, K2 -> 1 }\n Token2 -> { K2 -> 1, K7 -> 10, K8 -> 1}\n Token3 -> { K1 -> 1 }\n }\n*)\nmodule Ticket_token_map = struct\n include Ticket_token_map\n\n (** Adds a ticket-token with a destination and an amount to the map.\n The layout of the map parameter is as described above. Its type is:\n\n (n num Destination_map.t) Ticket_token_map.t\n\n As explained above, the inner map expresses a list of destination\n contracts and outgoing amount pairs.\n\n Invariant:\n - The internal contract-indexed map cannot be empty.\n\n *)\n let add ctxt ~ticket_token ~destination ~(amount : Ticket_amount.t) map =\n Ticket_token_map.update\n ctxt\n ticket_token\n (fun ctxt old_val ->\n match old_val with\n | None ->\n (* Create a new map with a single contract-and amount pair. *)\n let map = Destination_map.singleton destination amount in\n ok (Some map, ctxt)\n | Some destination_map ->\n (* Update the inner contract map *)\n let update ctxt prev_amt_opt =\n match prev_amt_opt with\n | Some (prev_amount : Ticket_amount.t) ->\n Gas.consume\n ctxt\n Script_int.(\n Ticket_costs.add_int_cost\n (prev_amount :> n num)\n (amount :> n num))\n >|? fun ctxt ->\n (Some (Ticket_amount.add prev_amount amount), ctxt)\n | None -> ok (Some amount, ctxt)\n in\n Destination_map.update ctxt destination update destination_map\n >|? fun (destination_map, ctxt) -> (Some destination_map, ctxt))\n map\nend\n\nlet tickets_of_transaction ctxt ~destination ~parameters_ty ~parameters =\n Ticket_scanner.type_has_tickets ctxt parameters_ty\n >>?= fun (has_tickets, ctxt) ->\n Ticket_scanner.tickets_of_value ~include_lazy:true ctxt has_tickets parameters\n >>=? fun (tickets, ctxt) -> return (Some {destination; tickets}, ctxt)\n\n(** Extract tickets of an origination operation by scanning the storage. *)\nlet tickets_of_origination ctxt ~preorigination ~storage_type ~storage =\n (* Extract any tickets from the storage. Note that if the type of the contract\n storage does not contain tickets, storage is not scanned. *)\n Ticket_scanner.type_has_tickets ctxt storage_type\n >>?= fun (has_tickets, ctxt) ->\n Ticket_scanner.tickets_of_value ctxt ~include_lazy:true has_tickets storage\n >|=? fun (tickets, ctxt) ->\n let destination = Destination.Contract (Originated preorigination) in\n (Some {tickets; destination}, ctxt)\n\nlet tickets_of_operation ctxt\n (Script_typed_ir.Internal_operation {source = _; operation; nonce = _}) =\n match operation with\n | Transaction_to_implicit _ -> return (None, ctxt)\n | Transaction_to_implicit_with_ticket\n {\n destination;\n ticket;\n ticket_ty = Script_typed_ir.Ticket_t (ty, _);\n unparsed_ticket = _;\n amount = _;\n } ->\n return\n ( Some\n {\n destination = Destination.Contract (Implicit destination);\n tickets = [Ex_ticket (ty, ticket)];\n },\n ctxt )\n | Transaction_to_smart_contract\n {\n amount = _;\n unparsed_parameters = _;\n entrypoint = _;\n destination;\n location = _;\n parameters_ty;\n parameters;\n } ->\n tickets_of_transaction\n ctxt\n ~destination:(Destination.Contract (Originated destination))\n ~parameters_ty\n ~parameters\n | Transaction_to_tx_rollup\n {destination; unparsed_parameters = _; parameters_ty; parameters} ->\n let Tx_rollup_parameters.{ex_ticket; l2_destination = _} =\n Tx_rollup_parameters.get_deposit_parameters parameters_ty parameters\n in\n return\n ( Some\n {\n destination = Destination.Tx_rollup destination;\n tickets = [ex_ticket];\n },\n ctxt )\n | Transaction_to_sc_rollup\n {\n destination;\n entrypoint = _;\n parameters_ty;\n parameters;\n unparsed_parameters = _;\n } ->\n (* Note that zero-amount tickets to a rollup is not permitted. *)\n tickets_of_transaction\n ctxt\n ~destination:(Destination.Sc_rollup destination)\n ~parameters_ty\n ~parameters\n | Transaction_to_zk_rollup\n {\n destination;\n unparsed_parameters = _;\n parameters_ty = Pair_t (Ticket_t (ty, _), Bytes_t, _, _);\n parameters = ticket, _op;\n } ->\n let ex_ticket = Ticket_scanner.Ex_ticket (ty, ticket) in\n return\n ( Some\n {\n destination = Destination.Zk_rollup destination;\n tickets = [ex_ticket];\n },\n ctxt )\n | Origination\n {\n delegate = _;\n code = _;\n unparsed_storage = _;\n credit = _;\n preorigination;\n storage_type;\n storage;\n } ->\n tickets_of_origination ctxt ~preorigination ~storage_type ~storage\n | Delegation _ | Event _ -> return (None, ctxt)\n\nlet add_transfer_to_token_map ctxt token_map {destination; tickets} =\n List.fold_left_es\n (fun (token_map, ctxt) ticket ->\n let ticket_token, amount =\n Ticket_scanner.ex_token_and_amount_of_ex_ticket ticket\n in\n Ticket_token_map.add ctxt ~ticket_token ~destination ~amount token_map)\n (token_map, ctxt)\n tickets\n\nlet ticket_token_map_of_operations ctxt ops =\n List.fold_left_es\n (fun (token_map, ctxt) op ->\n tickets_of_operation ctxt op >>=? fun (res, ctxt) ->\n match res with\n | Some ticket_trans ->\n add_transfer_to_token_map ctxt token_map ticket_trans\n | None -> return (token_map, ctxt))\n (Ticket_token_map.empty, ctxt)\n ops\n\n(** Traverses a list of operations and scans for tickets. *)\nlet ticket_diffs_of_operations ctxt operations =\n ticket_token_map_of_operations ctxt operations >>=? fun (token_map, ctxt) ->\n Ticket_token_map.fold_e\n ctxt\n (fun ctxt acc ticket_token destination_map ->\n (* Calculate the total amount of outgoing units for the current\n ticket-token. *)\n Destination_map.fold_e\n ctxt\n (fun ctxt total_amount _destination (amount : Ticket_amount.t) ->\n Gas.consume\n ctxt\n Script_int.(\n Ticket_costs.add_int_cost total_amount (amount :> n num))\n >|? fun ctxt ->\n (Script_int.(add_n total_amount (amount :> n num)), ctxt))\n Script_int.zero_n\n destination_map\n >>? fun (total_amount, ctxt) ->\n Destination_map.to_list ctxt destination_map\n >|? fun (destinations, ctxt) ->\n ({ticket_token; total_amount; destinations} :: acc, ctxt))\n []\n token_map\n |> Lwt.return\n" ;
} ;
{ name = "Ticket_accounting" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\n(** [ticket_diffs ctxt ~arg_type_has_tickets ~storage_type_has_tickets arg\n old_storage new_storage lazy_storage_diff] returns a map from\n ticket-tokens to balance-differences that represents the change in balance\n for a contract due to changes of tickets in the storage. The assumption is\n that before calling [ticket_diffs], all tickets that are owned by a contract\n exist either in the [old_storage] or the [arg]. After execution, only\n tickets in [new_storage] are owned by the contract. Note that this function\n avoids traversing the lazy part of the storage.\n*)\nval ticket_diffs :\n context ->\n self_contract:Contract.t ->\n arg_type_has_tickets:'arg Ticket_scanner.has_tickets ->\n storage_type_has_tickets:'storage Ticket_scanner.has_tickets ->\n arg:'arg ->\n old_storage:'storage ->\n new_storage:'storage ->\n lazy_storage_diff:Lazy_storage.diffs_item list ->\n (Z.t Ticket_token_map.t * Ticket_receipt.t * context) tzresult Lwt.t\n\n(** [ticket_balances_of_value ctxt ~include_lazy has_tickets value]\n scans all tickets in the given [value] using the type-witness [has_tickets]\n and returns a map from ticket-tokens to the amount. *)\nval ticket_balances_of_value :\n context ->\n include_lazy:bool ->\n 'a Ticket_scanner.has_tickets ->\n 'a ->\n (Z.t Ticket_token_map.t * context) tzresult Lwt.t\n\n(** [update_ticket_balances ctxt ~self_contract ~ticket_diffs operations] updates the\n ticket balances according to the [ticket_diffs] map and the set of\n operations. The function also returns the storage size diff resulting from\n updating the ticket-balance table in the context.\n\n Invariant: this function must be called after applying the lazy-storage\n diffs affecting any contracts in the given operations.\n\n The function fails in case an invalid ticket-token-balance update is\n detected. The [ticket_diffs] argument represents the change of ticket-tokens\n for the [self] contract. It also specifies a \"budget\" for outgoing\n ticket-tokens.\n*)\nval update_ticket_balances :\n context ->\n self_contract:Contract.t ->\n ticket_diffs:Z.t Ticket_token_map.t ->\n Script_typed_ir.packed_internal_operation list ->\n (Z.t * context) tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\ntype error += Invalid_ticket_transfer of {ticketer : string; amount : Z.t}\n\nlet () =\n let open Data_encoding in\n register_error_kind\n `Permanent\n ~id:\"invalid_ticket_transfer\"\n ~title:\"Invalid ticket transfer\"\n ~description:\"Invalid ticket transfer detected in ticket balance update.\"\n ~pp:(fun ppf (ticketer, amount) ->\n Format.fprintf\n ppf\n \"Attempted to send %a unit(s) of a ticket created by %s.\"\n Z.pp_print\n amount\n ticketer)\n (obj2 (req \"ticketer\" (string Plain)) (req \"amount\" z))\n (function\n | Invalid_ticket_transfer {ticketer; amount} -> Some (ticketer, amount)\n | _ -> None)\n (fun (ticketer, amount) -> Invalid_ticket_transfer {ticketer; amount})\n\nmodule Ticket_token_map = struct\n include Ticket_token_map\n\n let balance_diff ctxt token map =\n let open Lwt_result_syntax in\n let+ amnt_opt, ctxt = Ticket_token_map.find ctxt token map in\n (Option.value ~default:Z.zero amnt_opt, ctxt)\n\n let merge_overlap ctxt b1 b2 =\n let open Result_syntax in\n let+ ctxt = Gas.consume ctxt (Ticket_costs.add_z_cost b1 b2) in\n (Z.add b1 b2, ctxt)\n\n let of_list ctxt token_amounts =\n Ticket_token_map.of_list ctxt ~merge_overlap token_amounts\n\n let add ctxt = Ticket_token_map.merge ctxt ~merge_overlap\n\n let sub ctxt m1 m2 =\n let open Result_syntax in\n let* m2, ctxt =\n map_e\n ctxt\n (fun ctxt _ex_token amount ->\n let+ ctxt = Gas.consume ctxt (Ticket_costs.negate_cost amount) in\n (Z.neg amount, ctxt))\n m2\n in\n add ctxt m1 m2\nend\n\nlet ticket_balances_of_value ctxt ~include_lazy ty value =\n let open Lwt_result_syntax in\n let* tickets, ctxt =\n Ticket_scanner.tickets_of_value ~include_lazy ctxt ty value\n in\n let accum_ticket_balances (acc, ctxt) ticket =\n let open Result_syntax in\n let token, amount =\n Ticket_scanner.ex_token_and_amount_of_ex_ticket ticket\n in\n let+ ctxt =\n Gas.consume ctxt Ticket_costs.Constants.cost_collect_tickets_step\n in\n ( (token, Script_int.to_zint (amount :> Script_int.n Script_int.num)) :: acc,\n ctxt )\n in\n let*? token_amounts, ctxt =\n List.fold_left_e accum_ticket_balances ([], ctxt) tickets\n in\n Ticket_token_map.of_list ctxt token_amounts\n\nlet update_ticket_balances ctxt ~total_storage_diff token destinations =\n let open Lwt_result_syntax in\n List.fold_left_es\n (fun (tot_storage_diff, ctxt) (owner, delta) ->\n let* key_hash, ctxt = Ticket_balance_key.of_ex_token ctxt ~owner token in\n let* storage_diff, ctxt =\n Ticket_balance.adjust_balance ctxt key_hash ~delta\n in\n let*? ctxt =\n Gas.consume\n ctxt\n (Ticket_costs.add_z_cost total_storage_diff storage_diff)\n in\n return (Z.add tot_storage_diff storage_diff, ctxt))\n (total_storage_diff, ctxt)\n destinations\n\nlet invalid_ticket_transfer_error\n ~ticket_token:\n (Ticket_token.Ex_token {ticketer; contents_type = _; contents = _})\n ~amount =\n Invalid_ticket_transfer {ticketer = Contract.to_b58check ticketer; amount}\n\nlet update_ticket_balances_for_self_contract ctxt ~self_contract ticket_diffs =\n let open Lwt_result_syntax in\n List.fold_left_es\n (fun (total_storage_diff, ctxt) (ticket_token, amount) ->\n (* Diff is valid iff either:\n - the balance has decreased (delta <= 0), or\n - the ticket-token was created by the [self] contract. *)\n let is_valid_balance_update =\n let (Ticket_token.Ex_token {ticketer; _}) = ticket_token in\n Compare.Z.(amount <= Z.zero) || Contract.equal ticketer self_contract\n in\n let*? () =\n error_unless\n is_valid_balance_update\n (invalid_ticket_transfer_error ~ticket_token ~amount)\n in\n update_ticket_balances\n ctxt\n ~total_storage_diff\n ticket_token\n [(Destination.Contract self_contract, amount)])\n (Z.zero, ctxt)\n ticket_diffs\n\nlet ticket_diffs_of_lazy_storage_diff ctxt ~storage_type_has_tickets\n lazy_storage_diff =\n let open Lwt_result_syntax in\n (* Only scan lazy-diffs for tickets in case the storage contains tickets. *)\n if Ticket_scanner.has_tickets storage_type_has_tickets then\n let* diffs, ctxt =\n Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff\n ctxt\n lazy_storage_diff\n in\n Ticket_token_map.of_list ctxt diffs\n else return (Ticket_token_map.empty, ctxt)\n\n(* TODO #2465\n Move the docs from HackMd to [docs/alpha] folder.\n The documentation referenced here should be moved to a permanent place and\n the comment below should be updated.\n*)\n\n(** Description here:\n https://hackmd.io/lutm_5JNRVW-nNFSFkCXLQ?view#Implementation\n\n - [old_storage_strict] the amount S_1^{strict} of ticket-tokens in the strict part of\n the old storage.\n\n - [new_storage_strict] the amount S_2^{strict} of ticket-tokens in the strict part of the\n new storage.\n\n - [lazy_storage_diff] the amount S_{\\delta}^{lazy} of ticket-tokens added to the lazy part of\n the storage.\n\n - [arg_tickets] the amount I of ticket-tokens contained in the incoming\n arguments.\n\n We calculate the ticket diff as the following:\n [new_storage_strict] + [lazy_storage_diff] - ([old_storage_strict] + [arg_tickets])\n\n Additionally, we calculate the ticket receipt as below.\n We do not subtract the [arg_tickets] since we only want to display the tickets updated in storage for the receipt.\n [new_storage_strict] + [lazy_storage_diff] - [storage_strict]\n *)\nlet ticket_diffs ctxt ~self_contract ~arg_type_has_tickets\n ~storage_type_has_tickets ~arg ~old_storage ~new_storage ~lazy_storage_diff\n =\n let open Lwt_result_syntax in\n (* Collect ticket-token balances of the incoming parameters. *)\n let* arg_tickets, ctxt =\n ticket_balances_of_value ctxt ~include_lazy:true arg_type_has_tickets arg\n in\n let* lazy_storage_diff, ctxt =\n ticket_diffs_of_lazy_storage_diff\n ctxt\n ~storage_type_has_tickets\n lazy_storage_diff\n in\n let* old_storage_strict, ctxt =\n ticket_balances_of_value\n ctxt\n ~include_lazy:false\n storage_type_has_tickets\n old_storage\n in\n let* new_storage_strict, ctxt =\n ticket_balances_of_value\n ctxt\n ~include_lazy:false\n storage_type_has_tickets\n new_storage\n in\n let*? additions, ctxt =\n Ticket_token_map.add ctxt new_storage_strict lazy_storage_diff\n in\n let*? total_storage_diff, ctxt =\n Ticket_token_map.sub ctxt additions old_storage_strict\n in\n let*? diff, ctxt = Ticket_token_map.sub ctxt total_storage_diff arg_tickets in\n let* ticket_receipt, ctxt =\n Ticket_token_map.to_ticket_receipt\n ctxt\n ~owner:Destination.(Contract self_contract)\n total_storage_diff\n in\n return (diff, ticket_receipt, ctxt)\n\nlet update_ticket_balances ctxt ~self_contract ~ticket_diffs operations =\n let open Lwt_result_syntax in\n let validate_spending_budget ctxt\n (Ticket_token.Ex_token {ticketer; _} as ticket_token) amount =\n if Contract.equal ticketer self_contract then\n (* It's okay to send any amount of ticket-tokens minted by the current\n contract (self). Hence tickets stored by their ticketer are not\n stored in the ticket table and don't need to be updated here. *)\n return (true, ctxt)\n else\n let+ balance_diff, ctxt =\n Ticket_token_map.balance_diff ctxt ticket_token ticket_diffs\n in\n (* The balance-diff represents the number of units of a ticket-token,\n that is changed for the [self] contract. A negative diff means that\n an amount of ticket-tokens were not saved in the storage and are\n eligible for transfer to another contract.\n\n For example, if 5 units of a ticket-token \"Alice Red\" were pulled from\n the storage, the corresponding diff is -5. That means at most 5 units\n of \"Alice Red\" can be transferred. Any amount exceeding that would\n result in a validation error.\n *)\n (Compare.Z.(Script_int.to_zint amount <= Z.neg balance_diff), ctxt)\n in\n (* Collect diffs from operations *)\n let* ticket_op_diffs, ctxt =\n Ticket_operations_diff.ticket_diffs_of_operations ctxt operations\n in\n (* Update balances for self-contract. *)\n let*? ticket_diffs, ctxt = Ticket_token_map.to_list ctxt ticket_diffs in\n let* total_storage_diff, ctxt =\n update_ticket_balances_for_self_contract ctxt ~self_contract ticket_diffs\n in\n (* Update balances for operations. *)\n List.fold_left_es\n (fun (total_storage_diff, ctxt)\n {Ticket_operations_diff.ticket_token; total_amount; destinations} ->\n (* Verify that we are able to spend the given amount of ticket-tokens. *)\n let* is_valid_balance_update, ctxt =\n validate_spending_budget ctxt ticket_token total_amount\n in\n let*? () =\n error_unless\n is_valid_balance_update\n (invalid_ticket_transfer_error\n ~ticket_token\n ~amount:(Script_int.to_zint total_amount))\n in\n let*? destinations, ctxt =\n List.fold_left_e\n (fun (acc, ctxt) (token, (amount : Script_typed_ir.ticket_amount)) ->\n (* Consume some gas for traversing the list. *)\n let open Result_syntax in\n let+ ctxt =\n Gas.consume ctxt Ticket_costs.Constants.cost_collect_tickets_step\n in\n ((token, Script_int.(to_zint (amount :> n num))) :: acc, ctxt))\n ([], ctxt)\n destinations\n in\n update_ticket_balances ctxt ~total_storage_diff ticket_token destinations)\n (total_storage_diff, ctxt)\n ticket_op_diffs\n" ;
} ;
{ name = "Ticket_transfer" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Margiold <contact@marigold.dev> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\n(** [parse_ticket ~ticketer ~contents ~ty\n ctxt] reconstructs a ticket from individual parts submitted as\n part of a layer-1 operation. *)\nval parse_ticket :\n consume_deserialization_gas:Script.consume_deserialization_gas ->\n ticketer:Contract.t ->\n contents:Script.lazy_expr ->\n ty:Script.lazy_expr ->\n context ->\n (context * Ticket_token.ex_token, error trace) result Lwt.t\n\n(** Same as [parse_ticket], but in addition, build a transaction to\n let [source] transfers [amount] units of said ticket to\n [destination]. *)\nval parse_ticket_and_operation :\n consume_deserialization_gas:Script.consume_deserialization_gas ->\n ticketer:Contract.t ->\n contents:Script.lazy_expr ->\n ty:Script.lazy_expr ->\n source:Destination.t ->\n destination:Contract_hash.t ->\n entrypoint:Entrypoint.t ->\n amount:Script_typed_ir.ticket_amount ->\n context ->\n (context * Ticket_token.ex_token * Script_typed_ir.packed_internal_operation)\n tzresult\n Lwt.t\n\n(** [transfer_ticket_with_hashes ctxt ~src_hash ~dst_hash qty] updates\n the table of tickets moves [qty] units of a given ticket from a\n source to a destination, as encoded by [src_hash] and [dst_hash].\n\n Consistency between [src_hash] and [dst_hash] is the\n responsibility of the caller. Whenever possible, [transfer_ticket]\n should be preferred, but [transfer_ticket_with_hashes] could be\n preferred to reduce gas comsumption (e.g., to reuse hashes already\n computed).\n\n In addition to an updated context, this function returns the\n number of bytes that were newly allocated for the table of\n tickets. *)\nval transfer_ticket_with_hashes :\n context ->\n src_hash:Ticket_hash.t ->\n dst_hash:Ticket_hash.t ->\n Ticket_amount.t ->\n (context * Z.t) tzresult Lwt.t\n\n(** [transfer_ticket ctxt ~src ~dst ex_token qty] updates the table of\n tickets moves [qty] units of [ex_token] from [src] to [dst], as\n encoded by [src_hash] and [dst_hash].\n\n In addition to an updated context, this function returns the\n number of bytes that were newly allocated for the table of\n tickets. *)\nval transfer_ticket :\n context ->\n src:Destination.t ->\n dst:Destination.t ->\n Ticket_token.ex_token ->\n Ticket_amount.t ->\n (context * Z.t, error trace) result Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Margiold <contact@marigold.dev> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\nlet parse_ticket ~consume_deserialization_gas ~ticketer ~contents ~ty ctxt =\n Script.force_decode_in_context ~consume_deserialization_gas ctxt ty\n >>?= fun (ty, ctxt) ->\n Script.force_decode_in_context ~consume_deserialization_gas ctxt contents\n >>?= fun (contents, ctxt) ->\n Script_ir_translator.parse_comparable_ty ctxt (Micheline.root ty)\n >>?= fun (Ex_comparable_ty contents_type, ctxt) ->\n Script_ir_translator.parse_comparable_data\n ctxt\n contents_type\n (Micheline.root contents)\n >>=? fun (contents, ctxt) ->\n let token = Ticket_token.Ex_token {ticketer; contents_type; contents} in\n return (ctxt, token)\n\nlet parse_ticket_and_operation ~consume_deserialization_gas ~ticketer ~contents\n ~ty ~source ~destination ~entrypoint ~amount ctxt =\n parse_ticket ~consume_deserialization_gas ~ticketer ~contents ~ty ctxt\n >>=? fun ( ctxt,\n (Ticket_token.Ex_token {contents; contents_type; ticketer} as\n token) ) ->\n Script_typed_ir.ticket_t Micheline.dummy_location contents_type\n >>?= fun ticket_ty ->\n let ticket = Script_typed_ir.{ticketer; contents; amount} in\n Script_ir_translator.unparse_data ctxt Optimized ticket_ty ticket\n >>=? fun (unparsed_parameters, ctxt) ->\n fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) ->\n let op =\n Script_typed_ir.Internal_operation\n {\n source;\n nonce;\n operation =\n Transaction_to_smart_contract\n {\n amount = Tez.zero;\n unparsed_parameters;\n destination;\n entrypoint;\n location = Micheline.dummy_location;\n parameters_ty = ticket_ty;\n parameters = ticket;\n };\n }\n in\n return (ctxt, token, op)\n\nlet transfer_ticket_with_hashes ctxt ~src_hash ~dst_hash (qty : Ticket_amount.t)\n =\n let qty = Script_int.(to_zint (qty :> n num)) in\n Ticket_balance.adjust_balance ctxt src_hash ~delta:(Z.neg qty)\n >>=? fun (src_storage_diff, ctxt) ->\n Ticket_balance.adjust_balance ctxt dst_hash ~delta:qty\n >>=? fun (dst_storage_diff, ctxt) ->\n Ticket_balance.adjust_storage_space\n ctxt\n ~storage_diff:(Z.add src_storage_diff dst_storage_diff)\n >>=? fun (diff, ctxt) -> return (ctxt, diff)\n\nlet transfer_ticket ctxt ~src ~dst ex_token qty =\n Ticket_balance_key.of_ex_token ctxt ~owner:src ex_token\n >>=? fun (src_hash, ctxt) ->\n Ticket_balance_key.of_ex_token ctxt ~owner:dst ex_token\n >>=? fun (dst_hash, ctxt) ->\n transfer_ticket_with_hashes ctxt ~src_hash ~dst_hash qty\n" ;
} ;
{ name = "Script_interpreter_defs" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(*\n\n This module provides auxiliary definitions used in the interpreter.\n\n These are internal private definitions. Do not rely on them outside\n the interpreter.\n\n*)\n\nopen Alpha_context\nopen Script\nopen Script_typed_ir\nopen Script_ir_translator\nopen Local_gas_counter\n\ntype error += Rollup_invalid_transaction_amount | Rollup_invalid_entrypoint\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"operation.rollup_invalid_transaction_amount\"\n ~title:\"Transaction amount to a rollup must be zero\"\n ~description:\n \"Because rollups are outside of the delegation mechanism of Tezos, they \\\n cannot own Tez, and therefore transactions targeting a rollup must have \\\n its amount field set to zero.\"\n ~pp:(fun ppf () ->\n Format.pp_print_string ppf \"Transaction amount to a rollup must be zero.\")\n Data_encoding.unit\n (function Rollup_invalid_transaction_amount -> Some () | _ -> None)\n (fun () -> Rollup_invalid_transaction_amount) ;\n register_error_kind\n `Permanent\n ~id:\"operation.rollup_invalid_entrypoint\"\n ~title:\"Only the default entrypoint is allowed for rollups\"\n ~description:\"Rollups only support transactions to the default entrypoint.\"\n ~pp:(fun ppf () ->\n Format.pp_print_string\n ppf\n \"Rollups only support transactions to the default entrypoint.\")\n Data_encoding.unit\n (function Rollup_invalid_entrypoint -> Some () | _ -> None)\n (fun () -> Rollup_invalid_entrypoint)\n\n(*\n\n Computing the cost of Michelson instructions\n ============================================\n\n The function [cost_of_instr] provides a cost model for Michelson\n instructions. It is used by the interpreter to track the\n consumption of gas. This consumption may depend on the values\n on the stack.\n\n *)\n\nmodule Interp_costs = Michelson_v1_gas.Cost_of.Interpreter\n\nlet cost_of_instr : type a s r f. (a, s, r, f) kinstr -> a -> s -> Gas.cost =\n fun i accu stack ->\n match i with\n | IList_map _ ->\n let list = accu in\n Interp_costs.list_map list\n | IList_iter _ ->\n let list = accu in\n Interp_costs.list_iter list\n | ISet_iter _ ->\n let set = accu in\n Interp_costs.set_iter set\n | ISet_mem _ ->\n let v = accu and set, _ = stack in\n Interp_costs.set_mem v set\n | ISet_update _ ->\n let v = accu and _, (set, _) = stack in\n Interp_costs.set_update v set\n | IMap_map _ ->\n let map = accu in\n Interp_costs.map_map map\n | IMap_iter _ ->\n let map = accu in\n Interp_costs.map_iter map\n | IMap_mem _ ->\n let v = accu and map, _ = stack in\n Interp_costs.map_mem v map\n | IMap_get _ ->\n let v = accu and map, _ = stack in\n Interp_costs.map_get v map\n | IMap_update _ ->\n let k = accu and _, (map, _) = stack in\n Interp_costs.map_update k map\n | IMap_get_and_update _ ->\n let k = accu and _, (map, _) = stack in\n Interp_costs.map_get_and_update k map\n | IBig_map_mem _ ->\n let Big_map map, _ = stack in\n Interp_costs.big_map_mem map.diff\n | IBig_map_get _ ->\n let Big_map map, _ = stack in\n Interp_costs.big_map_get map.diff\n | IBig_map_update _ ->\n let _, (Big_map map, _) = stack in\n Interp_costs.big_map_update map.diff\n | IBig_map_get_and_update _ ->\n let _, (Big_map map, _) = stack in\n Interp_costs.big_map_get_and_update map.diff\n | IAdd_seconds_to_timestamp _ ->\n let n = accu and t, _ = stack in\n Interp_costs.add_seconds_timestamp n t\n | IAdd_timestamp_to_seconds _ ->\n let t = accu and n, _ = stack in\n Interp_costs.add_timestamp_seconds t n\n | ISub_timestamp_seconds _ ->\n let t = accu and n, _ = stack in\n Interp_costs.sub_timestamp_seconds t n\n | IDiff_timestamps _ ->\n let t1 = accu and t2, _ = stack in\n Interp_costs.diff_timestamps t1 t2\n | IConcat_string_pair _ ->\n let x = accu and y, _ = stack in\n Interp_costs.concat_string_pair x y\n | IConcat_string _ ->\n let ss = accu in\n Interp_costs.concat_string_precheck ss\n | ISlice_string _ ->\n let (_offset : Script_int.n Script_int.num) = accu in\n let _length, (s, _) = stack in\n Interp_costs.slice_string s\n | IConcat_bytes_pair _ ->\n let x = accu and y, _ = stack in\n Interp_costs.concat_bytes_pair x y\n | IConcat_bytes _ ->\n let ss = accu in\n Interp_costs.concat_string_precheck ss\n | ISlice_bytes _ ->\n let _, (s, _) = stack in\n Interp_costs.slice_bytes s\n | IBytes_nat _ ->\n let n = accu in\n Interp_costs.bytes_nat n\n | INat_bytes _ ->\n let b = accu in\n Interp_costs.nat_bytes b\n | IBytes_int _ ->\n let n = accu in\n Interp_costs.bytes_int n\n | IInt_bytes _ ->\n let b = accu in\n Interp_costs.int_bytes b\n | IMul_teznat _ -> Interp_costs.mul_teznat\n | IMul_nattez _ -> Interp_costs.mul_nattez\n | IAbs_int _ ->\n let x = accu in\n Interp_costs.abs_int x\n | INeg _ ->\n let x = accu in\n Interp_costs.neg x\n | IAdd_int _ ->\n let x = accu and y, _ = stack in\n Interp_costs.add_int x y\n | IAdd_nat _ ->\n let x = accu and y, _ = stack in\n Interp_costs.add_nat x y\n | ISub_int _ ->\n let x = accu and y, _ = stack in\n Interp_costs.sub_int x y\n | IMul_int _ ->\n let x = accu and y, _ = stack in\n Interp_costs.mul_int x y\n | IMul_nat _ ->\n let x = accu and y, _ = stack in\n Interp_costs.mul_nat x y\n | IEdiv_teznat _ ->\n let x = accu and y, _ = stack in\n Interp_costs.ediv_teznat x y\n | IEdiv_int _ ->\n let x = accu and y, _ = stack in\n Interp_costs.ediv_int x y\n | IEdiv_nat _ ->\n let x = accu and y, _ = stack in\n Interp_costs.ediv_nat x y\n | ILsl_nat _ ->\n let x = accu in\n Interp_costs.lsl_nat x\n | ILsl_bytes _ ->\n let x = accu in\n let y, _ = stack in\n Interp_costs.lsl_bytes x y\n | ILsr_nat _ ->\n let x = accu in\n Interp_costs.lsr_nat x\n | ILsr_bytes _ ->\n let x = accu in\n let y, _ = stack in\n Interp_costs.lsr_bytes x y\n | IOr_nat _ ->\n let x = accu and y, _ = stack in\n Interp_costs.or_nat x y\n | IOr_bytes _ ->\n let x = accu and y, _ = stack in\n Interp_costs.or_bytes x y\n | IAnd_nat _ ->\n let x = accu and y, _ = stack in\n Interp_costs.and_nat x y\n | IAnd_int_nat _ ->\n let x = accu and y, _ = stack in\n Interp_costs.and_int_nat x y\n | IAnd_bytes _ ->\n let x = accu and y, _ = stack in\n Interp_costs.and_bytes x y\n | IXor_nat _ ->\n let x = accu and y, _ = stack in\n Interp_costs.xor_nat x y\n | IXor_bytes _ ->\n let x = accu and y, _ = stack in\n Interp_costs.xor_bytes x y\n | INot_int _ ->\n let x = accu in\n Interp_costs.not_int x\n | INot_bytes _ ->\n let x = accu in\n Interp_costs.not_bytes x\n | ICompare (_, ty, _) ->\n let a = accu and b, _ = stack in\n Interp_costs.compare ty a b\n | ICheck_signature _ ->\n let key = accu and _, (message, _) = stack in\n Interp_costs.check_signature key message\n | IHash_key _ ->\n let pk = accu in\n Interp_costs.hash_key pk\n | IBlake2b _ ->\n let bytes = accu in\n Interp_costs.blake2b bytes\n | ISha256 _ ->\n let bytes = accu in\n Interp_costs.sha256 bytes\n | ISha512 _ ->\n let bytes = accu in\n Interp_costs.sha512 bytes\n | IKeccak _ ->\n let bytes = accu in\n Interp_costs.keccak bytes\n | ISha3 _ ->\n let bytes = accu in\n Interp_costs.sha3 bytes\n | IPairing_check_bls12_381 _ ->\n let pairs = accu in\n Interp_costs.pairing_check_bls12_381 pairs\n | ISapling_verify_update _ ->\n let tx = accu in\n let inputs = Gas_input_size.sapling_transaction_inputs tx in\n let outputs = Gas_input_size.sapling_transaction_outputs tx in\n let bound_data = Gas_input_size.sapling_transaction_bound_data tx in\n Interp_costs.sapling_verify_update ~inputs ~outputs ~bound_data\n | ISapling_verify_update_deprecated _ ->\n let tx = accu in\n let inputs = List.length tx.inputs in\n let outputs = List.length tx.outputs in\n Interp_costs.sapling_verify_update_deprecated ~inputs ~outputs\n | ISplit_ticket _ ->\n let (amount_a, amount_b), _ = stack in\n Interp_costs.split_ticket amount_a amount_b\n | IJoin_tickets (_, ty, _) ->\n let ticket_a, ticket_b = accu in\n Interp_costs.join_tickets ty ticket_a ticket_b\n | IHalt _ -> Interp_costs.halt\n | IDrop _ -> Interp_costs.drop\n | IDup _ -> Interp_costs.dup\n | ISwap _ -> Interp_costs.swap\n | IConst _ -> Interp_costs.const\n | ICons_some _ -> Interp_costs.cons_some\n | ICons_none _ -> Interp_costs.cons_none\n | IIf_none _ -> Interp_costs.if_none\n | IOpt_map _ -> Interp_costs.opt_map\n | ICons_pair _ -> Interp_costs.cons_pair\n | IUnpair _ -> Interp_costs.unpair\n | ICar _ -> Interp_costs.car\n | ICdr _ -> Interp_costs.cdr\n | ICons_left _ -> Interp_costs.cons_left\n | ICons_right _ -> Interp_costs.cons_right\n | IIf_left _ -> Interp_costs.if_left\n | ICons_list _ -> Interp_costs.cons_list\n | INil _ -> Interp_costs.nil\n | IIf_cons _ -> Interp_costs.if_cons\n | IList_size _ -> Interp_costs.list_size\n | IEmpty_set _ -> Interp_costs.empty_set\n | ISet_size _ -> Interp_costs.set_size\n | IEmpty_map _ -> Interp_costs.empty_map\n | IMap_size _ -> Interp_costs.map_size\n | IEmpty_big_map _ -> Interp_costs.empty_big_map\n | IString_size _ -> Interp_costs.string_size\n | IBytes_size _ -> Interp_costs.bytes_size\n | IAdd_tez _ -> Interp_costs.add_tez\n | ISub_tez _ -> Interp_costs.sub_tez\n | ISub_tez_legacy _ -> Interp_costs.sub_tez_legacy\n | IOr _ -> Interp_costs.bool_or\n | IAnd _ -> Interp_costs.bool_and\n | IXor _ -> Interp_costs.bool_xor\n | INot _ -> Interp_costs.bool_not\n | IIs_nat _ -> Interp_costs.is_nat\n | IInt_nat _ -> Interp_costs.int_nat\n | IInt_bls12_381_fr _ -> Interp_costs.int_bls12_381_fr\n | IEdiv_tez _ -> Interp_costs.ediv_tez\n | IIf _ -> Interp_costs.if_\n | ILoop _ -> Interp_costs.loop\n | ILoop_left _ -> Interp_costs.loop_left\n | IDip _ -> Interp_costs.dip\n | IExec _ -> Interp_costs.exec\n | IApply _ -> (\n let l, _ = stack in\n match l with\n | Lam _ -> Interp_costs.apply ~rec_flag:false\n | LamRec _ -> Interp_costs.apply ~rec_flag:true)\n | ILambda _ -> Interp_costs.lambda\n | IFailwith _ -> Gas.free\n | IEq _ -> Interp_costs.eq\n | INeq _ -> Interp_costs.neq\n | ILt _ -> Interp_costs.lt\n | ILe _ -> Interp_costs.le\n | IGt _ -> Interp_costs.gt\n | IGe _ -> Interp_costs.ge\n | IPack _ -> Gas.free\n | IUnpack _ ->\n let b = accu in\n Interp_costs.unpack b\n | IAddress _ -> Interp_costs.address\n | IContract _ -> Interp_costs.contract\n | ITransfer_tokens _ -> Interp_costs.transfer_tokens\n | IView _ -> Interp_costs.view\n | IImplicit_account _ -> Interp_costs.implicit_account\n | ISet_delegate _ -> Interp_costs.set_delegate\n | IBalance _ -> Interp_costs.balance\n | ILevel _ -> Interp_costs.level\n | INow _ -> Interp_costs.now\n | IMin_block_time _ -> Interp_costs.min_block_time\n | ISapling_empty_state _ -> Interp_costs.sapling_empty_state\n | ISource _ -> Interp_costs.source\n | ISender _ -> Interp_costs.sender\n | ISelf _ -> Interp_costs.self\n | ISelf_address _ -> Interp_costs.self_address\n | IAmount _ -> Interp_costs.amount\n | IDig (_, n, _, _) -> Interp_costs.dign n\n | IDug (_, n, _, _) -> Interp_costs.dugn n\n | IDipn (_, n, _, _, _) -> Interp_costs.dipn n\n | IDropn (_, n, _, _) -> Interp_costs.dropn n\n | IChainId _ -> Interp_costs.chain_id\n | ICreate_contract _ -> Interp_costs.create_contract\n | INever _ -> ( match accu with _ -> .)\n | IVoting_power _ -> Interp_costs.voting_power\n | ITotal_voting_power _ -> Interp_costs.total_voting_power\n | IAdd_bls12_381_g1 _ -> Interp_costs.add_bls12_381_g1\n | IAdd_bls12_381_g2 _ -> Interp_costs.add_bls12_381_g2\n | IAdd_bls12_381_fr _ -> Interp_costs.add_bls12_381_fr\n | IMul_bls12_381_g1 _ -> Interp_costs.mul_bls12_381_g1\n | IMul_bls12_381_g2 _ -> Interp_costs.mul_bls12_381_g2\n | IMul_bls12_381_fr _ -> Interp_costs.mul_bls12_381_fr\n | INeg_bls12_381_g1 _ -> Interp_costs.neg_bls12_381_g1\n | INeg_bls12_381_g2 _ -> Interp_costs.neg_bls12_381_g2\n | INeg_bls12_381_fr _ -> Interp_costs.neg_bls12_381_fr\n | IMul_bls12_381_fr_z _ ->\n let z = accu in\n Interp_costs.mul_bls12_381_fr_z z\n | IMul_bls12_381_z_fr _ ->\n let z, _ = stack in\n Interp_costs.mul_bls12_381_z_fr z\n | IDup_n (_, n, _, _) -> Interp_costs.dupn n\n | IComb (_, n, _, _) -> Interp_costs.comb n\n | IUncomb (_, n, _, _) -> Interp_costs.uncomb n\n | IComb_get (_, n, _, _) -> Interp_costs.comb_get n\n | IComb_set (_, n, _, _) -> Interp_costs.comb_set n\n | ITicket _ | ITicket_deprecated _ -> Interp_costs.ticket\n | IRead_ticket _ -> Interp_costs.read_ticket\n | IOpen_chest _ ->\n let (_chest_key : Script_timelock.chest_key) = accu\n and chest, (time, _) = stack in\n Interp_costs.open_chest ~chest ~time:(Script_int.to_zint time)\n | IEmit _ -> Interp_costs.emit\n | ILog _ -> Gas.free\n [@@ocaml.inline always]\n\nlet cost_of_control : type a s r f. (a, s, r, f) continuation -> Gas.cost =\n fun ks ->\n match ks with\n | KLog _ -> Gas.free\n | KNil -> Interp_costs.Control.nil\n | KCons (_, _) -> Interp_costs.Control.cons\n | KReturn _ -> Interp_costs.Control.return\n | KMap_head (_, _) -> Interp_costs.Control.map_head\n | KUndip (_, _, _) -> Interp_costs.Control.undip\n | KLoop_in (_, _) -> Interp_costs.Control.loop_in\n | KLoop_in_left (_, _) -> Interp_costs.Control.loop_in_left\n | KIter (_, _, _, _) -> Interp_costs.Control.iter\n | KList_enter_body (_, xs, _, _, len, _) ->\n Interp_costs.Control.list_enter_body xs len\n | KList_exit_body (_, _, _, _, _, _) -> Interp_costs.Control.list_exit_body\n | KMap_enter_body (_, _, _, _, _) -> Interp_costs.Control.map_enter_body\n | KMap_exit_body (_, _, map, key, _, _) ->\n Interp_costs.Control.map_exit_body key map\n | KView_exit (_, _) -> Interp_costs.Control.view_exit\n\n(*\n\n [step] calls [consume_instr] at the beginning of each execution step.\n\n [Local_gas_counter.consume] is used in the implementation of\n [IConcat_string] and [IConcat_bytes] because in that special cases, the\n cost is expressed with respect to a non-constant-time computation on the\n inputs.\n\n*)\n\nlet consume_instr local_gas_counter k accu stack =\n let cost = cost_of_instr k accu stack in\n consume_opt local_gas_counter cost\n [@@ocaml.inline always]\n\nlet consume_control local_gas_counter ks =\n let cost = cost_of_control ks in\n consume_opt local_gas_counter cost\n [@@ocaml.inline always]\n\nlet get_log = function\n | None -> Lwt.return (Ok None)\n | Some logger -> logger.get_log ()\n [@@ocaml.inline always]\n\n(*\n\n Auxiliary functions used by the interpretation loop\n ===================================================\n\n*)\n\n(* The following function pops n elements from the stack\n and push their reintroduction in the continuations stack. *)\nlet rec kundip :\n type a s e z c u d w b t.\n (a, s, e, z, c, u, d, w) stack_prefix_preservation_witness ->\n c ->\n u ->\n (d, w, b, t) kinstr ->\n a * s * (e, z, b, t) kinstr =\n fun w accu stack k ->\n match w with\n | KPrefix (loc, ty, w) ->\n let k = IConst (loc, ty, accu, k) in\n let accu, stack = stack in\n kundip w accu stack k\n | KRest -> (accu, stack, k)\n\n(* [apply ctxt gas ty v lam] specializes [lam] by fixing its first\n formal argument to [v]. The type of [v] is represented by [ty]. *)\nlet apply ctxt gas capture_ty capture lam =\n let loc = Micheline.dummy_location in\n let ctxt = update_context gas ctxt in\n Script_ir_unparser.unparse_ty ~loc ctxt capture_ty >>?= fun (ty_expr, ctxt) ->\n unparse_data ctxt Optimized capture_ty capture >>=? fun (const_expr, ctxt) ->\n let make_expr expr =\n Micheline.(\n Seq\n ( loc,\n Prim (loc, I_PUSH, [ty_expr; Micheline.root const_expr], [])\n :: Prim (loc, I_PAIR, [], [])\n :: expr ))\n in\n let lam' =\n match lam with\n | LamRec (descr, expr) -> (\n let (Item_t (full_arg_ty, Item_t (Lambda_t (_, _, _), Bot_t))) =\n descr.kbef\n in\n let (Item_t (ret_ty, Bot_t)) = descr.kaft in\n Script_ir_unparser.unparse_ty ~loc ctxt full_arg_ty\n >>?= fun (arg_ty_expr, ctxt) ->\n Script_ir_unparser.unparse_ty ~loc ctxt ret_ty\n >>?= fun (ret_ty_expr, ctxt) ->\n match full_arg_ty with\n | Pair_t (capture_ty, arg_ty, _, _) ->\n let arg_stack_ty = Item_t (arg_ty, Bot_t) in\n (* To avoid duplicating the recursive lambda [lam], we\n return a regular lambda that builds the tuple of\n parameters and applies it to `lam`. Since `lam` is\n recursive it will push itself on top of the stack at\n execution time. *)\n let full_descr =\n {\n kloc = descr.kloc;\n kbef = arg_stack_ty;\n kaft = descr.kaft;\n kinstr =\n IConst\n ( descr.kloc,\n capture_ty,\n capture,\n ICons_pair\n ( descr.kloc,\n ILambda\n ( descr.kloc,\n lam,\n ISwap\n ( descr.kloc,\n IExec\n ( descr.kloc,\n Some descr.kaft,\n IHalt descr.kloc ) ) ) ) );\n }\n in\n let full_expr =\n make_expr\n Micheline.\n [\n Prim\n (loc, I_LAMBDA_REC, [arg_ty_expr; ret_ty_expr; expr], []);\n Prim (loc, I_SWAP, [], []);\n Prim (loc, I_EXEC, [], []);\n ]\n in\n return (Lam (full_descr, full_expr), ctxt))\n | Lam (descr, expr) -> (\n let (Item_t (full_arg_ty, Bot_t)) = descr.kbef in\n match full_arg_ty with\n | Pair_t (capture_ty, arg_ty, _, _) ->\n let arg_stack_ty = Item_t (arg_ty, Bot_t) in\n let full_descr =\n {\n kloc = descr.kloc;\n kbef = arg_stack_ty;\n kaft = descr.kaft;\n kinstr =\n IConst\n ( descr.kloc,\n capture_ty,\n capture,\n ICons_pair (descr.kloc, descr.kinstr) );\n }\n in\n let full_expr = make_expr [expr] in\n return (Lam (full_descr, full_expr), ctxt))\n in\n lam' >>=? fun (lam', ctxt) ->\n let gas, ctxt = local_gas_counter_and_outdated_context ctxt in\n return (lam', ctxt, gas)\n\nlet make_transaction_to_tx_rollup (type t) ctxt ~destination ~amount\n ~(parameters_ty : ((t ticket, tx_rollup_l2_address) pair, _) ty) ~parameters\n =\n (* The entrypoints of a transaction rollup are polymorphic wrt. the\n tickets it can process. However, two Michelson values can have\n the same Micheline representation, but different types. What\n this means is that when we start the execution of a transaction\n rollup, the type of its argument is lost if we just give it the\n values provided by the Michelson script.\n\n To address this issue, we instrument a transfer to a transaction\n rollup to inject the exact type of the entrypoint as used by\n the smart contract. This allows the transaction rollup to extract\n the type of the ticket. *)\n error_unless Tez.(amount = zero) Rollup_invalid_transaction_amount\n >>?= fun () ->\n let (Pair_t (Ticket_t (tp, _), _, _, _)) = parameters_ty in\n unparse_data ctxt Optimized parameters_ty parameters\n >>=? fun (unparsed_parameters, ctxt) ->\n Lwt.return\n ( Script_ir_unparser.unparse_ty ~loc:Micheline.dummy_location ctxt tp\n >>? fun (ty, ctxt) ->\n let unparsed_parameters =\n Micheline.Seq\n (Micheline.dummy_location, [Micheline.root unparsed_parameters; ty])\n in\n Gas.consume ctxt (Script.strip_locations_cost unparsed_parameters)\n >|? fun ctxt ->\n let unparsed_parameters = Micheline.strip_locations unparsed_parameters in\n ( Transaction_to_tx_rollup\n {destination; parameters_ty; parameters; unparsed_parameters},\n ctxt ) )\n\nlet make_transaction_to_sc_rollup ctxt ~destination ~amount ~entrypoint\n ~parameters_ty ~parameters =\n error_unless Tez.(amount = zero) Rollup_invalid_transaction_amount\n >>?= fun () ->\n (* TODO: https://gitlab.com/tezos/tezos/-/issues/4023\n We currently don't support entrypoints as the entrypoint information\n for L1 to L2 messages is not propagated to the rollup. *)\n error_unless (Entrypoint.is_default entrypoint) Rollup_invalid_entrypoint\n >>?= fun () ->\n unparse_data ctxt Optimized parameters_ty parameters\n >|=? fun (unparsed_parameters, ctxt) ->\n ( Transaction_to_sc_rollup\n {destination; entrypoint; parameters_ty; parameters; unparsed_parameters},\n ctxt )\n\n(** [emit_event] generates an internal operation that will effect an event emission\n if the contract code returns this successfully. *)\nlet emit_event (type t tc) (ctxt, sc) gas ~(event_type : (t, tc) ty)\n ~unparsed_ty ~tag ~(event_data : t) =\n let ctxt = update_context gas ctxt in\n (* No need to take care of lazy storage as only packable types are allowed *)\n let lazy_storage_diff = None in\n unparse_data ctxt Optimized event_type event_data\n >>=? fun (unparsed_data, ctxt) ->\n fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) ->\n let operation = Event {ty = unparsed_ty; tag; unparsed_data} in\n let iop =\n {\n source = Destination.Contract (Contract.Originated sc.self);\n operation;\n nonce;\n }\n in\n let res = {piop = Internal_operation iop; lazy_storage_diff} in\n let gas, ctxt = local_gas_counter_and_outdated_context ctxt in\n return (res, ctxt, gas)\n\nlet make_transaction_to_zk_rollup (type t) ctxt ~destination ~amount\n ~(parameters_ty : ((t ticket, bytes) pair, _) ty) ~parameters =\n error_unless Tez.(amount = zero) Rollup_invalid_transaction_amount\n >>?= fun () ->\n unparse_data ctxt Optimized parameters_ty parameters\n >|=? fun (unparsed_parameters, ctxt) ->\n ( Transaction_to_zk_rollup\n {destination; parameters_ty; parameters; unparsed_parameters},\n ctxt )\n\n(* [transfer (ctxt, sc) gas tez parameters_ty parameters destination entrypoint]\n creates an operation that transfers an amount of [tez] to a destination and\n an entrypoint instantiated with argument [parameters] of type\n [parameters_ty]. *)\nlet transfer (type t) (ctxt, sc) gas amount location\n (typed_contract : t typed_contract) (parameters : t) =\n let ctxt = update_context gas ctxt in\n (match typed_contract with\n | Typed_implicit destination ->\n let () = parameters in\n return (Transaction_to_implicit {destination; amount}, None, ctxt)\n | Typed_implicit_with_ticket {destination; ticket_ty} ->\n unparse_data ctxt Optimized ticket_ty parameters\n >>=? fun (unparsed_ticket, ctxt) ->\n return\n ( Transaction_to_implicit_with_ticket\n {\n destination;\n amount;\n ticket_ty;\n ticket = parameters;\n unparsed_ticket = Script.lazy_expr unparsed_ticket;\n },\n None,\n ctxt )\n | Typed_originated\n {arg_ty = parameters_ty; contract_hash = destination; entrypoint} ->\n collect_lazy_storage ctxt parameters_ty parameters\n >>?= fun (to_duplicate, ctxt) ->\n let to_update = no_lazy_storage_id in\n extract_lazy_storage_diff\n ctxt\n Optimized\n parameters_ty\n parameters\n ~to_duplicate\n ~to_update\n ~temporary:true\n >>=? fun (parameters, lazy_storage_diff, ctxt) ->\n unparse_data ctxt Optimized parameters_ty parameters\n >|=? fun (unparsed_parameters, ctxt) ->\n ( Transaction_to_smart_contract\n {\n destination;\n amount;\n entrypoint;\n location;\n parameters_ty;\n parameters;\n unparsed_parameters;\n },\n lazy_storage_diff,\n ctxt )\n | Typed_tx_rollup {arg_ty = parameters_ty; tx_rollup = destination} ->\n make_transaction_to_tx_rollup\n ctxt\n ~destination\n ~amount\n ~parameters_ty\n ~parameters\n >|=? fun (operation, ctxt) -> (operation, None, ctxt)\n | Typed_sc_rollup\n {arg_ty = parameters_ty; sc_rollup = destination; entrypoint} ->\n make_transaction_to_sc_rollup\n ctxt\n ~destination\n ~amount\n ~entrypoint\n ~parameters_ty\n ~parameters\n >|=? fun (operation, ctxt) -> (operation, None, ctxt)\n | Typed_zk_rollup {arg_ty = parameters_ty; zk_rollup = destination} ->\n make_transaction_to_zk_rollup\n ctxt\n ~destination\n ~amount\n ~parameters_ty\n ~parameters\n >|=? fun (operation, ctxt) -> (operation, None, ctxt))\n >>=? fun (operation, lazy_storage_diff, ctxt) ->\n fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) ->\n let iop =\n {\n source = Destination.Contract (Contract.Originated sc.self);\n operation;\n nonce;\n }\n in\n let res = {piop = Internal_operation iop; lazy_storage_diff} in\n let gas, ctxt = local_gas_counter_and_outdated_context ctxt in\n return (res, ctxt, gas)\n\n(** [create_contract (ctxt, sc) gas storage_ty code delegate credit init]\n creates an origination operation for a contract represented by [code], some\n initial [credit] (withdrawn from the contract being executed), and an\n initial storage [init] of type [storage_ty]. *)\nlet create_contract (ctxt, sc) gas storage_type code delegate credit init =\n let ctxt = update_context gas ctxt in\n collect_lazy_storage ctxt storage_type init >>?= fun (to_duplicate, ctxt) ->\n let to_update = no_lazy_storage_id in\n extract_lazy_storage_diff\n ctxt\n Optimized\n storage_type\n init\n ~to_duplicate\n ~to_update\n ~temporary:true\n >>=? fun (init, lazy_storage_diff, ctxt) ->\n unparse_data ctxt Optimized storage_type init\n >>=? fun (unparsed_storage, ctxt) ->\n Contract.fresh_contract_from_current_nonce ctxt\n >>?= fun (ctxt, preorigination) ->\n let operation =\n Origination\n {\n credit;\n delegate;\n code;\n unparsed_storage;\n preorigination;\n storage_type;\n storage = init;\n }\n in\n fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) ->\n let source = Destination.Contract (Contract.Originated sc.self) in\n let piop = Internal_operation {source; operation; nonce} in\n let res = {piop; lazy_storage_diff} in\n let gas, ctxt = local_gas_counter_and_outdated_context ctxt in\n return (res, preorigination, ctxt, gas)\n\n(* [unpack ctxt ty bytes] deserialize [bytes] into a value of type [ty]. *)\nlet unpack ctxt ~ty ~bytes =\n Gas.consume\n ctxt\n (Script.deserialization_cost_estimated_from_bytes (Bytes.length bytes))\n >>?= fun ctxt ->\n if\n Compare.Int.(Bytes.length bytes >= 1)\n && Compare.Int.(TzEndian.get_uint8 bytes 0 = 0x05)\n then\n let str = Bytes.sub_string bytes 1 (Bytes.length bytes - 1) in\n match Data_encoding.Binary.of_string_opt Script.expr_encoding str with\n | None ->\n Lwt.return\n ( Gas.consume ctxt (Interp_costs.unpack_failed str) >|? fun ctxt ->\n (None, ctxt) )\n | Some expr -> (\n parse_data\n ctxt\n ~elab_conf:Script_ir_translator_config.(make ~legacy:false ())\n ~allow_forged:false\n ty\n (Micheline.root expr)\n >|= function\n | Ok (value, ctxt) -> ok (Some value, ctxt)\n | Error _ignored ->\n Gas.consume ctxt (Interp_costs.unpack_failed str) >|? fun ctxt ->\n (None, ctxt))\n else return (None, ctxt)\n\n(* [interp_stack_prefix_preserving_operation f w accu stack] applies\n a well-typed operation [f] under some prefix of the A-stack\n exploiting [w] to justify that the shape of the stack is\n preserved. *)\nlet rec interp_stack_prefix_preserving_operation :\n type a s b t c u d w result.\n (a -> s -> (b * t) * result) ->\n (a, s, b, t, c, u, d, w) stack_prefix_preservation_witness ->\n c ->\n u ->\n (d * w) * result =\n fun f n accu stk ->\n match (n, stk) with\n | KPrefix (_, _, n), rest ->\n interp_stack_prefix_preserving_operation f n (fst rest) (snd rest)\n |> fun ((v, rest'), result) -> ((accu, (v, rest')), result)\n | KRest, v -> f accu v\n\n(*\n\n Some auxiliary functions have complex types and must be annotated\n because of GADTs and polymorphic recursion.\n\n To improve readibility, we introduce their types as abbreviations:\n\n *)\n\n(* A function of this type either introduces type-preserving\n instrumentation of a continuation for the purposes of logging\n or returns given continuation unchanged. *)\ntype ('a, 'b, 'c, 'd) cont_instrumentation =\n ('a, 'b, 'c, 'd) continuation -> ('a, 'b, 'c, 'd) continuation\n\nlet id x = x\n\ntype ('a, 'b, 'c, 'e, 'f, 'm, 'n, 'o) kmap_exit_type =\n ('a, 'b, 'e, 'f) cont_instrumentation ->\n outdated_context * step_constants ->\n local_gas_counter ->\n ('m * 'n, 'a * 'b, 'o, 'a * 'b) kinstr ->\n ('m * 'n) list ->\n (('m, 'o) map, 'c) ty option ->\n ('m, 'o) map ->\n 'm ->\n (('m, 'o) map, 'a * 'b, 'e, 'f) continuation ->\n 'o ->\n 'a * 'b ->\n ('e * 'f * outdated_context * local_gas_counter) tzresult Lwt.t\n\ntype ('a, 'b, 'c, 'd, 'e, 'f, 'j, 'k) kmap_enter_type =\n ('a, 'b * 'c, 'd, 'e) cont_instrumentation ->\n outdated_context * step_constants ->\n local_gas_counter ->\n ('j * 'k, 'b * 'c, 'a, 'b * 'c) kinstr ->\n ('j * 'k) list ->\n (('j, 'a) map, 'f) ty option ->\n ('j, 'a) map ->\n (('j, 'a) map, 'b * 'c, 'd, 'e) continuation ->\n 'b ->\n 'c ->\n ('d * 'e * outdated_context * local_gas_counter) tzresult Lwt.t\n\ntype ('a, 'b, 'c, 'd, 'e, 'i, 'j) klist_exit_type =\n ('a, 'b, 'c, 'd) cont_instrumentation ->\n outdated_context * step_constants ->\n local_gas_counter ->\n ('i, 'a * 'b, 'j, 'a * 'b) kinstr ->\n 'i list ->\n 'j Script_list.t ->\n ('j Script_list.t, 'e) ty option ->\n int ->\n ('j Script_list.t, 'a * 'b, 'c, 'd) continuation ->\n 'j ->\n 'a * 'b ->\n ('c * 'd * outdated_context * local_gas_counter) tzresult Lwt.t\n\ntype ('a, 'b, 'c, 'd, 'e, 'f, 'j) klist_enter_type =\n ('b, 'a * 'c, 'd, 'e) cont_instrumentation ->\n outdated_context * step_constants ->\n local_gas_counter ->\n ('j, 'a * 'c, 'b, 'a * 'c) kinstr ->\n 'j list ->\n 'b Script_list.t ->\n ('b Script_list.t, 'f) ty option ->\n int ->\n ('b Script_list.t, 'a * 'c, 'd, 'e) continuation ->\n 'a ->\n 'c ->\n ('d * 'e * outdated_context * local_gas_counter) tzresult Lwt.t\n\ntype ('a, 'b, 'c, 'd, 'e, 'f, 'g) kloop_in_left_type =\n outdated_context * step_constants ->\n local_gas_counter ->\n ('c, 'd, 'e, 'f) continuation ->\n ('a, 'g, 'c, 'd) kinstr ->\n ('b, 'g, 'e, 'f) continuation ->\n ('a, 'b) union ->\n 'g ->\n ('e * 'f * outdated_context * local_gas_counter) tzresult Lwt.t\n\ntype ('a, 'b, 'c, 'r, 'f, 's) kloop_in_type =\n outdated_context * step_constants ->\n local_gas_counter ->\n ('b, 'c, 'r, 'f) continuation ->\n ('a, 's, 'b, 'c) kinstr ->\n ('a, 's, 'r, 'f) continuation ->\n bool ->\n 'a * 's ->\n ('r * 'f * outdated_context * local_gas_counter) tzresult Lwt.t\n\ntype ('a, 'b, 's, 'r, 'f, 'c) kiter_type =\n ('a, 's, 'r, 'f) cont_instrumentation ->\n outdated_context * step_constants ->\n local_gas_counter ->\n ('b, 'a * 's, 'a, 's) kinstr ->\n ('b, 'c) ty option ->\n 'b list ->\n ('a, 's, 'r, 'f) continuation ->\n 'a ->\n 's ->\n ('r * 'f * outdated_context * local_gas_counter) tzresult Lwt.t\n\ntype ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i) ilist_map_type =\n ('a, 'b, 'c, 'd) cont_instrumentation ->\n outdated_context * step_constants ->\n local_gas_counter ->\n ('e, 'a * 'b, 'f, 'a * 'b) kinstr ->\n ('f Script_list.t, 'a * 'b, 'g, 'h) kinstr ->\n ('g, 'h, 'c, 'd) continuation ->\n ('f Script_list.t, 'i) ty option ->\n 'e Script_list.t ->\n 'a * 'b ->\n ('c * 'd * outdated_context * local_gas_counter) tzresult Lwt.t\n\ntype ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'cmp) ilist_iter_type =\n ('a, 'b, 'c, 'd) cont_instrumentation ->\n outdated_context * step_constants ->\n local_gas_counter ->\n ('e, 'a * 'b, 'a, 'b) kinstr ->\n ('e, 'cmp) ty option ->\n ('a, 'b, 'f, 'g) kinstr ->\n ('f, 'g, 'c, 'd) continuation ->\n 'e Script_list.t ->\n 'a * 'b ->\n ('c * 'd * outdated_context * local_gas_counter) tzresult Lwt.t\n\ntype ('a, 'b, 'c, 'd, 'e, 'f, 'g) iset_iter_type =\n ('a, 'b, 'c, 'd) cont_instrumentation ->\n outdated_context * step_constants ->\n local_gas_counter ->\n ('e, 'a * 'b, 'a, 'b) kinstr ->\n 'e comparable_ty option ->\n ('a, 'b, 'f, 'g) kinstr ->\n ('f, 'g, 'c, 'd) continuation ->\n 'e set ->\n 'a * 'b ->\n ('c * 'd * outdated_context * local_gas_counter) tzresult Lwt.t\n\ntype ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, 'j) imap_map_type =\n ('a, 'b, 'c, 'd) cont_instrumentation ->\n outdated_context * step_constants ->\n local_gas_counter ->\n ('e * 'f, 'a * 'b, 'g, 'a * 'b) kinstr ->\n (('e, 'g) map, 'a * 'b, 'h, 'i) kinstr ->\n ('h, 'i, 'c, 'd) continuation ->\n (('e, 'g) map, 'j) ty option ->\n ('e, 'f) map ->\n 'a * 'b ->\n ('c * 'd * outdated_context * local_gas_counter) tzresult Lwt.t\n\ntype ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'cmp) imap_iter_type =\n ('a, 'b, 'c, 'd) cont_instrumentation ->\n outdated_context * step_constants ->\n local_gas_counter ->\n ('e * 'f, 'a * 'b, 'a, 'b) kinstr ->\n ('e * 'f, 'cmp) ty option ->\n ('a, 'b, 'g, 'h) kinstr ->\n ('g, 'h, 'c, 'd) continuation ->\n ('e, 'f) map ->\n 'a * 'b ->\n ('c * 'd * outdated_context * local_gas_counter) tzresult Lwt.t\n\ntype ('a, 'b, 'c, 'd, 'e, 'f) imul_teznat_type =\n logger option ->\n outdated_context * step_constants ->\n local_gas_counter ->\n Script.location ->\n (Tez.t, 'b, 'c, 'd) kinstr ->\n ('c, 'd, 'e, 'f) continuation ->\n Tez.t ->\n Script_int.n Script_int.num * 'b ->\n ('e * 'f * outdated_context * local_gas_counter, error trace) result Lwt.t\n\ntype ('a, 'b, 'c, 'd, 'e, 'f) imul_nattez_type =\n logger option ->\n outdated_context * step_constants ->\n local_gas_counter ->\n Script.location ->\n (Tez.t, 'b, 'c, 'd) kinstr ->\n ('c, 'd, 'e, 'f) continuation ->\n Script_int.n Script_int.num ->\n Tez.t * 'b ->\n ('e * 'f * outdated_context * local_gas_counter, error trace) result Lwt.t\n\ntype ('a, 'b, 'c, 'd, 'e, 'f) ilsl_nat_type =\n logger option ->\n outdated_context * step_constants ->\n local_gas_counter ->\n Script.location ->\n (Script_int.n Script_int.num, 'b, 'c, 'd) kinstr ->\n ('c, 'd, 'e, 'f) continuation ->\n Script_int.n Script_int.num ->\n Script_int.n Script_int.num * 'b ->\n ('e * 'f * outdated_context * local_gas_counter, error trace) result Lwt.t\n\ntype ('a, 'b, 'c, 'd, 'e, 'f) ilsr_nat_type =\n logger option ->\n outdated_context * step_constants ->\n local_gas_counter ->\n Script.location ->\n (Script_int.n Script_int.num, 'b, 'c, 'd) kinstr ->\n ('c, 'd, 'e, 'f) continuation ->\n Script_int.n Script_int.num ->\n Script_int.n Script_int.num * 'b ->\n ('e * 'f * outdated_context * local_gas_counter, error trace) result Lwt.t\n\ntype ('a, 'b, 'c, 'd, 'e, 'f) ilsl_bytes_type =\n logger option ->\n outdated_context * step_constants ->\n local_gas_counter ->\n Script.location ->\n (bytes, 'b, 'c, 'd) kinstr ->\n ('c, 'd, 'e, 'f) continuation ->\n bytes ->\n Script_int.n Script_int.num * 'b ->\n ('e * 'f * outdated_context * local_gas_counter, error trace) result Lwt.t\n\ntype ifailwith_type = {\n ifailwith :\n 'a 'ac 'b.\n logger option ->\n outdated_context * step_constants ->\n local_gas_counter ->\n Script.location ->\n ('a, 'ac) ty ->\n 'a ->\n ('b, error trace) result Lwt.t;\n}\n[@@unboxed]\n\ntype ('a, 'b, 'c, 'd, 'e, 'f, 'g) iexec_type =\n ('a, end_of_stack, 'e, 'f) cont_instrumentation ->\n logger option ->\n outdated_context * step_constants ->\n local_gas_counter ->\n ('a, 'b) stack_ty option ->\n ('a, 'b, 'c, 'd) kinstr ->\n ('c, 'd, 'e, 'f) continuation ->\n 'g ->\n ('g, 'a) lambda * 'b ->\n ('e * 'f * outdated_context * local_gas_counter) tzresult Lwt.t\n\ntype ('a, 'b, 'c, 'd, 'e, 'f, 'i, 'o) iview_type =\n ('o, end_of_stack, 'e, 'f) cont_instrumentation ->\n outdated_context * step_constants ->\n local_gas_counter ->\n ('i, 'o) view_signature ->\n ('a, 'b) stack_ty option ->\n ('o option, 'a * 'b, 'c, 'd) kinstr ->\n ('c, 'd, 'e, 'f) continuation ->\n 'i ->\n address * ('a * 'b) ->\n ('e * 'f * outdated_context * local_gas_counter) tzresult Lwt.t\n" ;
} ;
{ name = "Script_interpreter" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This is the Michelson interpreter.\n\n This module offers a way to execute either a Michelson script or a\n Michelson instruction.\n\n Implementation details are documented in the .ml file.\n\n*)\n\nopen Alpha_context\nopen Script_typed_ir\n\ntype error += Reject of Script.location * Script.expr * execution_trace option\n\ntype error += Overflow of Script.location * execution_trace option\n\ntype error += Runtime_contract_error of Contract_hash.t\n\ntype error += Bad_contract_parameter of Contract.t (* `Permanent *)\n\ntype error += Cannot_serialize_failure\n\ntype error += Cannot_serialize_storage\n\ntype error += Michelson_too_many_recursive_calls\n\n(** The result from script interpretation. *)\ntype execution_result = {\n script : Script_ir_translator.ex_script;\n code_size : int;\n storage : Script.expr;\n lazy_storage_diff : Lazy_storage.diffs option;\n operations : packed_internal_operation list;\n ticket_diffs : Z.t Ticket_token_map.t;\n ticket_receipt : Ticket_receipt.t;\n}\n\ntype step_constants = Script_typed_ir.step_constants = {\n source : Destination.t;\n payer : Signature.public_key_hash;\n self : Contract_hash.t;\n amount : Tez.t;\n balance : Tez.t;\n chain_id : Chain_id.t;\n now : Script_timestamp.t;\n level : Script_int.n Script_int.num;\n}\n\n(** [execute ?logger ctxt ~cached_script mode step_constant ~script\n ~entrypoint ~parameter ~internal] interprets the [script]'s\n [entrypoint] for a given [parameter].\n\n This will update the local storage of the contract\n [step_constants.self]. Other pieces of contextual information\n ([source], [payer], [amount], and [chaind_id]) are also passed in\n [step_constant].\n\n [internal] is [true] if and only if the execution happens within an\n internal operation.\n\n [mode] is the unparsing mode, as declared by\n {!Script_ir_translator}.\n\n [cached_script] is the cached elaboration of [script], that is the\n well typed abstract syntax tree produced by the type elaboration of\n [script] during a previous execution and stored in the in-memory\n cache.\n\n*)\nval execute :\n ?logger:logger ->\n Alpha_context.t ->\n cached_script:Script_ir_translator.ex_script option ->\n Script_ir_unparser.unparsing_mode ->\n step_constants ->\n script:Script.t ->\n entrypoint:Entrypoint.t ->\n parameter:Script.expr ->\n internal:bool ->\n (execution_result * context) tzresult Lwt.t\n\n(** [execute_with_typed_parameter ?logger ctxt ~cached_script mode\n step_constant ~script ~entrypoint loc ~parameter_ty ~parameter ~internal]\n interprets the [script]'s [entrypoint] for a given (typed) [parameter].\n\n See {!execute} for more details about the function's arguments.\n*)\nval execute_with_typed_parameter :\n ?logger:logger ->\n Alpha_context.context ->\n cached_script:Script_ir_translator.ex_script option ->\n Script_ir_unparser.unparsing_mode ->\n step_constants ->\n script:Script.t ->\n entrypoint:Entrypoint.t ->\n parameter_ty:('a, _) Script_typed_ir.ty ->\n location:Script.location ->\n parameter:'a ->\n internal:bool ->\n (execution_result * context) tzresult Lwt.t\n\n(** Internal interpretation loop\n ============================\n\n The following types and the following functions are exposed\n in the interface to allow the inference of a gas model in\n snoop.\n\n Strictly speaking, they should not be considered as part of\n the interface since they expose implementation details that\n may change in the future.\n\n*)\n\nmodule Internals : sig\n (** Internally, the interpretation loop uses a local gas counter. *)\n\n (** [next logger (ctxt, step_constants) local_gas_counter ks accu\n stack] is an internal function which interprets the continuation\n [ks] to execute the interpreter on the current A-stack. *)\n val next :\n logger option ->\n Local_gas_counter.outdated_context * step_constants ->\n Local_gas_counter.local_gas_counter ->\n ('a, 's) stack_ty ->\n ('a, 's, 'r, 'f) continuation ->\n 'a ->\n 's ->\n ('r\n * 'f\n * Local_gas_counter.outdated_context\n * Local_gas_counter.local_gas_counter)\n tzresult\n Lwt.t\n\n val step :\n Local_gas_counter.outdated_context * step_constants ->\n Local_gas_counter.local_gas_counter ->\n ('a, 's, 'r, 'f) Script_typed_ir.kinstr ->\n 'a ->\n 's ->\n ('r\n * 'f\n * Local_gas_counter.outdated_context\n * Local_gas_counter.local_gas_counter)\n tzresult\n Lwt.t\n\n val step_descr :\n logger option ->\n context ->\n Script_typed_ir.step_constants ->\n ('a, 's, 'r, 'f) Script_typed_ir.kdescr ->\n 'a ->\n 's ->\n ('r * 'f * context) tzresult Lwt.t\n\n (** [kstep logger ctxt step_constants kinstr accu stack] interprets the\n script represented by [kinstr] under the context [ctxt]. This will\n turn a stack whose topmost element is [accu] and remaining elements\n [stack] into a new accumulator and a new stack. This function also\n returns an updated context. If [logger] is given, [kstep] calls back\n its functions at specific points of the execution. The execution is\n parameterized by some [step_constants]. *)\n val kstep :\n logger option ->\n context ->\n step_constants ->\n ('a, 's) stack_ty ->\n ('a, 's, 'r, 'f) Script_typed_ir.kinstr ->\n 'a ->\n 's ->\n ('r * 'f * context) tzresult Lwt.t\n\n module Raw : sig\n open Local_gas_counter\n open Script_interpreter_defs\n\n val kmap_exit : ('a, 'b, 'c, 'e, 'f, 'm, 'n, 'o) kmap_exit_type\n\n val kmap_enter : ('a, 'b, 'c, 'd, 'f, 'i, 'j, 'k) kmap_enter_type\n\n val klist_exit : ('a, 'b, 'c, 'd, 'e, 'i, 'j) klist_exit_type\n\n val klist_enter : ('a, 'b, 'c, 'd, 'e, 'f, 'j) klist_enter_type\n\n val kloop_in_left : ('a, 'b, 'c, 'd, 'e, 'f, 'g) kloop_in_left_type\n\n val kloop_in : ('a, 'b, 'c, 'r, 'f, 's) kloop_in_type\n\n val kiter : ('a, 'b, 's, 'r, 'f, 'c) kiter_type\n\n val next :\n outdated_context * step_constants ->\n local_gas_counter ->\n ('a, 's, 'r, 'f) continuation ->\n 'a ->\n 's ->\n ('r * 'f * outdated_context * local_gas_counter) tzresult Lwt.t\n\n val ilist_map : ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i) ilist_map_type\n\n val ilist_iter : ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'cmp) ilist_iter_type\n\n val iset_iter : ('a, 'b, 'c, 'd, 'e, 'f, 'g) iset_iter_type\n\n val imap_map : ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, 'j) imap_map_type\n\n val imap_iter : ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'cmp) imap_iter_type\n\n val imul_teznat : ('a, 'b, 'c, 'd, 'e, 'f) imul_teznat_type\n\n val imul_nattez : ('a, 'b, 'c, 'd, 'e, 'f) imul_nattez_type\n\n val ilsl_nat : ('a, 'b, 'c, 'd, 'e, 'f) ilsl_nat_type\n\n val ilsr_nat : ('a, 'b, 'c, 'd, 'e, 'f) ilsr_nat_type\n\n val ifailwith : ifailwith_type\n\n val iexec : ('a, 'b, 'c, 'd, 'e, 'f, 'g) iexec_type\n\n val iview : ('a, 'b, 'c, 'd, 'e, 'f, 'i, 'o) iview_type\n\n val step : ('a, 's, 'b, 't, 'r, 'f) step_type\n end\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 DaiLambda, Inc. <contact@dailambda,jp> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(*\n\n This module implements an interpreter for Michelson. It takes the\n form of a [step] function that interprets script instructions in a\n dedicated abstract machine.\n\n The interpreter is written in a small-step style: an execution\n [step] only interprets a single instruction by updating the\n configuration of a dedicated abstract machine.\n\n This abstract machine has two components:\n\n - a stack to control which instructions must be executed ; and\n\n - a stack of values where instructions get their inputs and put\n their outputs.\n\n In addition, the machine has access to effectful primitives to\n interact with the execution environment (e.g. the Tezos\n node). These primitives live in the [Lwt+State+Error] monad. Hence,\n this interpreter produces a computation in the [Lwt+State+Error]\n monad.\n\n This interpreter enjoys the following properties:\n\n - The interpreter is tail-recursive, hence it is robust to stack\n overflow. This property is checked by the compiler thanks to the\n [@ocaml.tailcall] annotation of each recursive call.\n\n - The interpreter is type-preserving. Thanks to GADTs, the typing\n rules of Michelson are statically checked by the OCaml typechecker:\n a Michelson program cannot go wrong.\n\n - The interpreter is tagless. Thanks to GADTs, the exact shape of\n the stack is known statically so the interpreter does not have to\n check that the input stack has the shape expected by the\n instruction to be executed.\n\n Outline\n =======\n\n This file is organized as follows:\n\n 1. Definition of runtime errors.\n\n 2. Interpretation loop: This is the main functionality of this\n module, aka the [step] function.\n\n 3. Interface functions: This part of the module builds high-level\n functions on top of the more basic [step] function.\n\n Auxiliary definitions can be found in {!Script_interpreter_defs}.\n\n Implementation details are explained along the file.\n\n*)\n\nopen Alpha_context\nopen Script_typed_ir\nopen Script_ir_translator\nopen Local_gas_counter\nopen Script_interpreter_defs\nmodule S = Saturation_repr\n\ntype step_constants = Script_typed_ir.step_constants = {\n source : Destination.t;\n payer : Signature.public_key_hash;\n self : Contract_hash.t;\n amount : Tez.t;\n balance : Tez.t;\n chain_id : Chain_id.t;\n now : Script_timestamp.t;\n level : Script_int.n Script_int.num;\n}\n\n(* ---- Run-time errors -----------------------------------------------------*)\n\ntype error += Reject of Script.location * Script.expr * execution_trace option\n\ntype error += Overflow of Script.location * execution_trace option\n\ntype error += Runtime_contract_error of Contract_hash.t\n\ntype error += Bad_contract_parameter of Contract.t (* `Permanent *)\n\ntype error += Cannot_serialize_failure\n\ntype error += Cannot_serialize_storage\n\ntype error += Michelson_too_many_recursive_calls\n\nlet () =\n let open Data_encoding in\n let trace_encoding : Script_typed_ir.execution_trace encoding =\n list\n @@ obj3\n (req \"location\" Script.location_encoding)\n (req \"gas\" Gas.Arith.z_fp_encoding)\n (req \"stack\" (list Script.expr_encoding))\n in\n (* Reject *)\n register_error_kind\n `Temporary\n ~id:\"michelson_v1.script_rejected\"\n ~title:\"Script failed\"\n ~description:\"A FAILWITH instruction was reached\"\n (obj3\n (req \"location\" Script.location_encoding)\n (req \"with\" Script.expr_encoding)\n (opt \"trace\" trace_encoding))\n (function Reject (loc, v, trace) -> Some (loc, v, trace) | _ -> None)\n (fun (loc, v, trace) -> Reject (loc, v, trace)) ;\n (* Overflow *)\n register_error_kind\n `Temporary\n ~id:\"michelson_v1.script_overflow\"\n ~title:\"Script failed (overflow error)\"\n ~description:\n \"A FAIL instruction was reached due to the detection of an overflow\"\n (obj2\n (req \"location\" Script.location_encoding)\n (opt \"trace\" trace_encoding))\n (function Overflow (loc, trace) -> Some (loc, trace) | _ -> None)\n (fun (loc, trace) -> Overflow (loc, trace)) ;\n (* Runtime contract error *)\n register_error_kind\n `Temporary\n ~id:\"michelson_v1.runtime_error\"\n ~title:\"Script runtime error\"\n ~description:\"Toplevel error for all runtime script errors\"\n (obj2\n (req \"contract_handle\" Contract.originated_encoding)\n (req \"contract_code\" (constant \"Deprecated\")))\n (function\n | Runtime_contract_error contract -> Some (contract, ()) | _ -> None)\n (fun (contract, ()) -> Runtime_contract_error contract) ;\n (* Bad contract parameter *)\n register_error_kind\n `Permanent\n ~id:\"michelson_v1.bad_contract_parameter\"\n ~title:\"Contract supplied an invalid parameter\"\n ~description:\n \"Either no parameter was supplied to a contract with a non-unit \\\n parameter type, a non-unit parameter was passed to an account, or a \\\n parameter was supplied of the wrong type\"\n Data_encoding.(obj1 (req \"contract\" Contract.encoding))\n (function Bad_contract_parameter c -> Some c | _ -> None)\n (fun c -> Bad_contract_parameter c) ;\n (* Cannot serialize failure *)\n register_error_kind\n `Temporary\n ~id:\"michelson_v1.cannot_serialize_failure\"\n ~title:\"Not enough gas to serialize argument of FAILWITH\"\n ~description:\n \"Argument of FAILWITH was too big to be serialized with the provided gas\"\n Data_encoding.empty\n (function Cannot_serialize_failure -> Some () | _ -> None)\n (fun () -> Cannot_serialize_failure) ;\n (* Cannot serialize storage *)\n register_error_kind\n `Temporary\n ~id:\"michelson_v1.cannot_serialize_storage\"\n ~title:\"Not enough gas to serialize execution storage\"\n ~description:\n \"The returned storage was too big to be serialized with the provided gas\"\n Data_encoding.empty\n (function Cannot_serialize_storage -> Some () | _ -> None)\n (fun () -> Cannot_serialize_storage)\n\n(*\n\n Interpretation loop\n ===================\n\n*)\n\n(*\n\n As announced earlier, the [step] function produces a computation in\n the [Lwt+State+Error] monad. The [State] monad is implemented by\n having the [context] passed as input and returned updated as\n output. The [Error] monad is represented by the [tzresult] type\n constructor.\n\n The [step] function is actually defined as an internal\n tail-recursive routine of the toplevel [step]. It monitors the gas\n level before executing the instruction under focus, once this is\n done, it recursively calls itself on the continuation held by the\n current instruction.\n\n For each pure instruction (i.e. that is not monadic), the\n interpretation simply updates the input arguments of the [step]\n function. Since these arguments are (most likely) stored in\n hardware registers and since the tail-recursive calls are compiled\n into direct jumps, this interpretation technique offers good\n performances while saving safety thanks to a rich typing.\n\n For each impure instruction, the interpreter makes use of monadic\n bindings to compose monadic primitives with the [step] function.\n Again, we make sure that the recursive calls to [step] are tail\n calls by annotating them with [@ocaml.tailcall].\n\n The [step] function is actually based on several mutually\n recursive functions that can be separated in two groups: the first\n group focuses on the evaluation of continuations while the second\n group is about evaluating the instructions.\n\n*)\n\nmodule Raw = struct\n (*\n\n Evaluation of continuations\n ===========================\n\n As explained in [Script_typed_ir], there are several kinds of\n continuations, each having a specific evaluation rules. The\n following group of functions starts with a list of evaluation\n rules for continuations that generate fresh continuations. This\n group ends with the definition of [next], which dispatches\n evaluation rules depending on the continuation at stake.\n\n Some of these functions generate fresh continuations. As such, they\n expect a constructor [instrument] which inserts a [KLog] if the\n evaluation is logged.\n\n *)\n let rec kmap_exit :\n type a b c e f m n o. (a, b, c, e, f, m, n, o) kmap_exit_type =\n fun instrument g gas body xs ty ys yk ks accu stack ->\n let ys = Script_map.update yk (Some accu) ys in\n let ks = instrument @@ KMap_enter_body (body, xs, ys, ty, ks) in\n let accu, stack = stack in\n (next [@ocaml.tailcall]) g gas ks accu stack\n [@@inline]\n\n and kmap_enter :\n type a b c d f i j k. (a, b, c, d, f, i, j, k) kmap_enter_type =\n fun instrument g gas body xs ty ys ks accu stack ->\n match xs with\n | [] -> (next [@ocaml.tailcall]) g gas ks ys (accu, stack)\n | (xk, xv) :: xs ->\n let ks = instrument @@ KMap_exit_body (body, xs, ys, xk, ty, ks) in\n let res = (xk, xv) in\n let stack = (accu, stack) in\n (step [@ocaml.tailcall]) g gas body ks res stack\n [@@inline]\n\n and klist_exit : type a b c d e i j. (a, b, c, d, e, i, j) klist_exit_type =\n fun instrument g gas body xs ys ty len ks accu stack ->\n let ys = Script_list.cons accu ys in\n let ks = instrument @@ KList_enter_body (body, xs, ys, ty, len, ks) in\n let accu, stack = stack in\n (next [@ocaml.tailcall]) g gas ks accu stack\n [@@inline]\n\n and klist_enter : type a b c d e f j. (a, b, c, d, e, f, j) klist_enter_type =\n fun instrument g gas body xs ys ty len ks' accu stack ->\n match xs with\n | [] ->\n let ys = Script_list.rev ys in\n (next [@ocaml.tailcall]) g gas ks' ys (accu, stack)\n | x :: xs ->\n let ks = instrument @@ KList_exit_body (body, xs, ys, ty, len, ks') in\n (step [@ocaml.tailcall]) g gas body ks x (accu, stack)\n [@@inline]\n\n and kloop_in_left :\n type a b c d e f g. (a, b, c, d, e, f, g) kloop_in_left_type =\n fun g gas ks0 ki ks' accu stack ->\n match accu with\n | L v -> (step [@ocaml.tailcall]) g gas ki ks0 v stack\n | R v -> (next [@ocaml.tailcall]) g gas ks' v stack\n [@@inline]\n\n and kloop_in : type a b c r f s. (a, b, c, r, f, s) kloop_in_type =\n fun g gas ks0 ki ks' accu stack ->\n let accu', stack' = stack in\n if accu then (step [@ocaml.tailcall]) g gas ki ks0 accu' stack'\n else (next [@ocaml.tailcall]) g gas ks' accu' stack'\n [@@inline]\n\n and kiter : type a b s r f c. (a, b, s, r, f, c) kiter_type =\n fun instrument g gas body ty xs ks accu stack ->\n match xs with\n | [] -> (next [@ocaml.tailcall]) g gas ks accu stack\n | x :: xs ->\n let ks = instrument @@ KIter (body, ty, xs, ks) in\n (step [@ocaml.tailcall]) g gas body ks x (accu, stack)\n [@@inline]\n\n and next :\n type a s r f.\n outdated_context * step_constants ->\n local_gas_counter ->\n (a, s, r, f) continuation ->\n a ->\n s ->\n (r * f * outdated_context * local_gas_counter) tzresult Lwt.t =\n fun ((ctxt, _) as g) gas ks0 accu stack ->\n match consume_control gas ks0 with\n | None -> tzfail Gas.Operation_quota_exceeded\n | Some gas -> (\n match ks0 with\n | KLog (ks, sty, logger) ->\n (logger.klog [@ocaml.tailcall]) logger g gas sty ks0 ks accu stack\n | KNil -> Lwt.return (Ok (accu, stack, ctxt, gas))\n | KCons (k, ks) -> (step [@ocaml.tailcall]) g gas k ks accu stack\n | KLoop_in (ki, ks') ->\n (kloop_in [@ocaml.tailcall]) g gas ks0 ki ks' accu stack\n | KReturn (stack', _, ks) ->\n (next [@ocaml.tailcall]) g gas ks accu stack'\n | KMap_head (f, ks) -> (next [@ocaml.tailcall]) g gas ks (f accu) stack\n | KLoop_in_left (ki, ks') ->\n (kloop_in_left [@ocaml.tailcall]) g gas ks0 ki ks' accu stack\n | KUndip (x, _, ks) -> (next [@ocaml.tailcall]) g gas ks x (accu, stack)\n | KIter (body, ty, xs, ks) ->\n (kiter [@ocaml.tailcall]) id g gas body ty xs ks accu stack\n | KList_enter_body (body, xs, ys, ty, len, ks) ->\n (klist_enter [@ocaml.tailcall])\n id\n g\n gas\n body\n xs\n ys\n ty\n len\n ks\n accu\n stack\n | KList_exit_body (body, xs, ys, ty, len, ks) ->\n (klist_exit [@ocaml.tailcall])\n id\n g\n gas\n body\n xs\n ys\n ty\n len\n ks\n accu\n stack\n | KMap_enter_body (body, xs, ys, ty, ks) ->\n (kmap_enter [@ocaml.tailcall]) id g gas body xs ty ys ks accu stack\n | KMap_exit_body (body, xs, ys, yk, ty, ks) ->\n (kmap_exit [@ocaml.tailcall])\n id\n g\n gas\n body\n xs\n ty\n ys\n yk\n ks\n accu\n stack\n | KView_exit (orig_step_constants, ks) ->\n let g = (fst g, orig_step_constants) in\n (next [@ocaml.tailcall]) g gas ks accu stack)\n\n (*\n\n Evaluation of instructions\n ==========================\n\n The following functions define evaluation rules for instructions that\n generate fresh continuations. As such, they expect a constructor\n [instrument] which inserts a [KLog] if the evaluation is logged.\n\n The [step] function is taking care of the evaluation of the other\n instructions.\n\n*)\n and ilist_map :\n type a b c d e f g h i. (a, b, c, d, e, f, g, h, i) ilist_map_type =\n fun instrument g gas body k ks ty accu stack ->\n let xs = accu.elements in\n let ys = Script_list.empty in\n let len = accu.length in\n let ks =\n instrument @@ KList_enter_body (body, xs, ys, ty, len, KCons (k, ks))\n in\n let accu, stack = stack in\n (next [@ocaml.tailcall]) g gas ks accu stack\n [@@inline]\n\n and ilist_iter :\n type a b c d e f g cmp. (a, b, c, d, e, f, g, cmp) ilist_iter_type =\n fun instrument g gas body ty k ks accu stack ->\n let xs = accu.elements in\n let ks = instrument @@ KIter (body, ty, xs, KCons (k, ks)) in\n let accu, stack = stack in\n (next [@ocaml.tailcall]) g gas ks accu stack\n [@@inline]\n\n and iset_iter : type a b c d e f g. (a, b, c, d, e, f, g) iset_iter_type =\n fun instrument g gas body ty k ks accu stack ->\n let set = accu in\n let l = List.rev (Script_set.fold (fun e acc -> e :: acc) set []) in\n let ks = instrument @@ KIter (body, ty, l, KCons (k, ks)) in\n let accu, stack = stack in\n (next [@ocaml.tailcall]) g gas ks accu stack\n [@@inline]\n\n and imap_map :\n type a b c d e f g h i j. (a, b, c, d, e, f, g, h, i, j) imap_map_type =\n fun instrument g gas body k ks ty accu stack ->\n let map = accu in\n let xs = List.rev (Script_map.fold (fun k v a -> (k, v) :: a) map []) in\n let ys = Script_map.empty_from map in\n let ks = instrument @@ KMap_enter_body (body, xs, ys, ty, KCons (k, ks)) in\n let accu, stack = stack in\n (next [@ocaml.tailcall]) g gas ks accu stack\n [@@inline]\n\n and imap_iter :\n type a b c d e f g h cmp. (a, b, c, d, e, f, g, h, cmp) imap_iter_type =\n fun instrument g gas body ty k ks accu stack ->\n let map = accu in\n let l = List.rev (Script_map.fold (fun k v a -> (k, v) :: a) map []) in\n let ks = instrument @@ KIter (body, ty, l, KCons (k, ks)) in\n let accu, stack = stack in\n (next [@ocaml.tailcall]) g gas ks accu stack\n [@@inline]\n\n and imul_teznat : type a b c d e f. (a, b, c, d, e, f) imul_teznat_type =\n fun logger g gas loc k ks accu stack ->\n let x = accu in\n let y, stack = stack in\n match Script_int.to_int64 y with\n | None -> get_log logger >>=? fun log -> tzfail (Overflow (loc, log))\n | Some y ->\n Tez.(x *? y) >>?= fun res ->\n (step [@ocaml.tailcall]) g gas k ks res stack\n\n and imul_nattez : type a b c d e f. (a, b, c, d, e, f) imul_nattez_type =\n fun logger g gas loc k ks accu stack ->\n let y = accu in\n let x, stack = stack in\n match Script_int.to_int64 y with\n | None -> get_log logger >>=? fun log -> tzfail (Overflow (loc, log))\n | Some y ->\n Tez.(x *? y) >>?= fun res ->\n (step [@ocaml.tailcall]) g gas k ks res stack\n\n and ilsl_nat : type a b c d e f. (a, b, c, d, e, f) ilsl_nat_type =\n fun logger g gas loc k ks accu stack ->\n let x = accu and y, stack = stack in\n match Script_int.shift_left_n x y with\n | None -> get_log logger >>=? fun log -> tzfail (Overflow (loc, log))\n | Some x -> (step [@ocaml.tailcall]) g gas k ks x stack\n\n and ilsr_nat : type a b c d e f. (a, b, c, d, e, f) ilsr_nat_type =\n fun logger g gas loc k ks accu stack ->\n let x = accu and y, stack = stack in\n match Script_int.shift_right_n x y with\n | None -> get_log logger >>=? fun log -> tzfail (Overflow (loc, log))\n | Some r -> (step [@ocaml.tailcall]) g gas k ks r stack\n\n and ilsl_bytes : type a b c d e f. (a, b, c, d, e, f) ilsl_bytes_type =\n fun logger g gas loc k ks accu stack ->\n let x = accu and y, stack = stack in\n match Script_bytes.bytes_lsl x y with\n | None -> get_log logger >>=? fun log -> tzfail (Overflow (loc, log))\n | Some res -> (step [@ocaml.tailcall]) g gas k ks res stack\n\n and ifailwith : ifailwith_type =\n {\n ifailwith =\n (fun logger (ctxt, _) gas kloc tv accu ->\n let v = accu in\n let ctxt = update_context gas ctxt in\n trace Cannot_serialize_failure (unparse_data ctxt Optimized tv v)\n >>=? fun (v, _ctxt) ->\n get_log logger >>=? fun log -> tzfail (Reject (kloc, v, log)));\n }\n\n and iexec : type a b c d e f g. (a, b, c, d, e, f, g) iexec_type =\n fun instrument logger g gas cont_sty k ks accu stack ->\n let arg = accu and code, stack = stack in\n let log_code b =\n let body =\n match logger with\n | None -> b.kinstr\n | Some logger -> logger.log_kinstr logger b.kbef b.kinstr\n in\n let ks = instrument @@ KReturn (stack, cont_sty, KCons (k, ks)) in\n (body, ks)\n in\n match code with\n | Lam (body, _) ->\n let body, ks = log_code body in\n (step [@ocaml.tailcall]) g gas body ks arg (EmptyCell, EmptyCell)\n | LamRec (body, _) ->\n let body, ks = log_code body in\n (step [@ocaml.tailcall]) g gas body ks arg (code, (EmptyCell, EmptyCell))\n\n and iview : type a b c d e f i o. (a, b, c, d, e, f, i, o) iview_type =\n fun instrument\n (ctxt, sc)\n gas\n (View_signature {name; input_ty; output_ty})\n stack_ty\n k\n ks\n accu\n stack ->\n let input = accu in\n let addr, stack = stack in\n let ctxt = update_context gas ctxt in\n let return_none ctxt =\n let gas, ctxt = local_gas_counter_and_outdated_context ctxt in\n (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack\n in\n let legacy = Script_ir_translator_config.make ~legacy:true () in\n match addr.destination with\n | Contract (Implicit _) | Tx_rollup _ | Sc_rollup _ | Zk_rollup _ ->\n (return_none [@ocaml.tailcall]) ctxt\n | Contract (Originated contract_hash as c) -> (\n Contract.get_script ctxt contract_hash >>=? fun (ctxt, script_opt) ->\n match script_opt with\n | None -> (return_none [@ocaml.tailcall]) ctxt\n | Some script -> (\n parse_script\n ~elab_conf:legacy\n ~allow_forged_in_storage:true\n ctxt\n script\n >>=? fun (Ex_script (Script {storage; storage_type; views; _}), ctxt)\n ->\n Gas.consume ctxt (Interp_costs.view_get name views) >>?= fun ctxt ->\n match Script_map.get name views with\n | None -> (return_none [@ocaml.tailcall]) ctxt\n | Some view -> (\n let view_result =\n Script_ir_translator.parse_view\n ctxt\n ~elab_conf:legacy\n storage_type\n view\n in\n trace_eval\n (fun () ->\n Script_tc_errors.Ill_typed_contract\n (Micheline.strip_locations view.view_code, []))\n view_result\n >>=? fun ( Typed_view\n {\n input_ty = input_ty';\n output_ty = output_ty';\n kinstr;\n original_code_expr = _;\n },\n ctxt ) ->\n let io_ty =\n let open Gas_monad.Syntax in\n let* out_eq =\n ty_eq ~error_details:Fast output_ty' output_ty\n in\n let+ in_eq = ty_eq ~error_details:Fast input_ty input_ty' in\n (out_eq, in_eq)\n in\n Gas_monad.run ctxt io_ty >>?= fun (eq, ctxt) ->\n match eq with\n | Error Inconsistent_types_fast ->\n (return_none [@ocaml.tailcall]) ctxt\n | Ok (Eq, Eq) ->\n let kcons = KCons (ICons_some (kinstr_location k, k), ks) in\n Contract.get_balance_carbonated ctxt c\n >>=? fun (ctxt, balance) ->\n let gas, ctxt =\n local_gas_counter_and_outdated_context ctxt\n in\n let sty =\n Option.map (fun t -> Item_t (output_ty, t)) stack_ty\n in\n (step [@ocaml.tailcall])\n ( ctxt,\n {\n source =\n Destination.Contract (Contract.Originated sc.self);\n self = contract_hash;\n amount = Tez.zero;\n balance;\n (* The following remain unchanged, but let's\n list them anyway, so that we don't forget\n to update something added later. *)\n payer = sc.payer;\n chain_id = sc.chain_id;\n now = sc.now;\n level = sc.level;\n } )\n gas\n kinstr\n (instrument\n @@ KView_exit (sc, KReturn (stack, sty, kcons)))\n (input, storage)\n (EmptyCell, EmptyCell))))\n\n and step : type a s b t r f. (a, s, b, t, r, f) step_type =\n fun ((ctxt, sc) as g) gas i ks accu stack ->\n match consume_instr gas i accu stack with\n | None -> tzfail Gas.Operation_quota_exceeded\n | Some gas -> (\n match i with\n | ILog (_, sty, event, logger, k) ->\n (logger.ilog [@ocaml.tailcall])\n logger\n event\n sty\n g\n gas\n k\n ks\n accu\n stack\n | IHalt _ -> (next [@ocaml.tailcall]) g gas ks accu stack\n (* stack ops *)\n | IDrop (_, k) ->\n let accu, stack = stack in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | IDup (_, k) -> (step [@ocaml.tailcall]) g gas k ks accu (accu, stack)\n | ISwap (_, k) ->\n let top, stack = stack in\n (step [@ocaml.tailcall]) g gas k ks top (accu, stack)\n | IConst (_, _ty, v, k) ->\n (step [@ocaml.tailcall]) g gas k ks v (accu, stack)\n (* options *)\n | ICons_some (_, k) ->\n (step [@ocaml.tailcall]) g gas k ks (Some accu) stack\n | ICons_none (_, _ty, k) ->\n (step [@ocaml.tailcall]) g gas k ks None (accu, stack)\n | IIf_none {branch_if_none; branch_if_some; k; _} -> (\n match accu with\n | None ->\n let accu, stack = stack in\n (step [@ocaml.tailcall])\n g\n gas\n branch_if_none\n (KCons (k, ks))\n accu\n stack\n | Some v ->\n (step [@ocaml.tailcall])\n g\n gas\n branch_if_some\n (KCons (k, ks))\n v\n stack)\n | IOpt_map {body; k; loc = _} -> (\n match accu with\n | None -> (step [@ocaml.tailcall]) g gas k ks None stack\n | Some v ->\n let ks' = KMap_head (Option.some, KCons (k, ks)) in\n (step [@ocaml.tailcall]) g gas body ks' v stack)\n (* pairs *)\n | ICons_pair (_, k) ->\n let b, stack = stack in\n (step [@ocaml.tailcall]) g gas k ks (accu, b) stack\n | IUnpair (_, k) ->\n let a, b = accu in\n (step [@ocaml.tailcall]) g gas k ks a (b, stack)\n | ICar (_, k) ->\n let a, _ = accu in\n (step [@ocaml.tailcall]) g gas k ks a stack\n | ICdr (_, k) ->\n let _, b = accu in\n (step [@ocaml.tailcall]) g gas k ks b stack\n (* unions *)\n | ICons_left (_, _tyb, k) ->\n (step [@ocaml.tailcall]) g gas k ks (L accu) stack\n | ICons_right (_, _tya, k) ->\n (step [@ocaml.tailcall]) g gas k ks (R accu) stack\n | IIf_left {branch_if_left; branch_if_right; k; _} -> (\n match accu with\n | L v ->\n (step [@ocaml.tailcall])\n g\n gas\n branch_if_left\n (KCons (k, ks))\n v\n stack\n | R v ->\n (step [@ocaml.tailcall])\n g\n gas\n branch_if_right\n (KCons (k, ks))\n v\n stack)\n (* lists *)\n | ICons_list (_, k) ->\n let tl, stack = stack in\n let accu = Script_list.cons accu tl in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | INil (_, _ty, k) ->\n let stack = (accu, stack) in\n let accu = Script_list.empty in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | IIf_cons {branch_if_cons; branch_if_nil; k; _} -> (\n match Script_list.uncons accu with\n | None ->\n let accu, stack = stack in\n (step [@ocaml.tailcall])\n g\n gas\n branch_if_nil\n (KCons (k, ks))\n accu\n stack\n | Some (hd, tl) ->\n (step [@ocaml.tailcall])\n g\n gas\n branch_if_cons\n (KCons (k, ks))\n hd\n (tl, stack))\n | IList_map (_, body, ty, k) ->\n (ilist_map [@ocaml.tailcall]) id g gas body k ks ty accu stack\n | IList_size (_, k) ->\n let list = accu in\n let len = Script_int.(abs (of_int list.length)) in\n (step [@ocaml.tailcall]) g gas k ks len stack\n | IList_iter (_, ty, body, k) ->\n (ilist_iter [@ocaml.tailcall]) id g gas body ty k ks accu stack\n (* sets *)\n | IEmpty_set (_, ty, k) ->\n let res = Script_set.empty ty in\n let stack = (accu, stack) in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | ISet_iter (_, ty, body, k) ->\n (iset_iter [@ocaml.tailcall]) id g gas body ty k ks accu stack\n | ISet_mem (_, k) ->\n let set, stack = stack in\n let res = Script_set.mem accu set in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | ISet_update (_, k) ->\n let presence, (set, stack) = stack in\n let res = Script_set.update accu presence set in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | ISet_size (_, k) ->\n let res = Script_set.size accu in\n (step [@ocaml.tailcall]) g gas k ks res stack\n (* maps *)\n | IEmpty_map (_, kty, _vty, k) ->\n let res = Script_map.empty kty and stack = (accu, stack) in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IMap_map (_, ty, body, k) ->\n (imap_map [@ocaml.tailcall]) id g gas body k ks ty accu stack\n | IMap_iter (_, kvty, body, k) ->\n (imap_iter [@ocaml.tailcall]) id g gas body kvty k ks accu stack\n | IMap_mem (_, k) ->\n let map, stack = stack in\n let res = Script_map.mem accu map in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IMap_get (_, k) ->\n let map, stack = stack in\n let res = Script_map.get accu map in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IMap_update (_, k) ->\n let v, (map, stack) = stack in\n let key = accu in\n let res = Script_map.update key v map in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IMap_get_and_update (_, k) ->\n let key = accu in\n let v, (map, rest) = stack in\n let map' = Script_map.update key v map in\n let v' = Script_map.get key map in\n (step [@ocaml.tailcall]) g gas k ks v' (map', rest)\n | IMap_size (_, k) ->\n let res = Script_map.size accu in\n (step [@ocaml.tailcall]) g gas k ks res stack\n (* Big map operations *)\n | IEmpty_big_map (_, tk, tv, k) ->\n let ebm = Script_big_map.empty tk tv in\n (step [@ocaml.tailcall]) g gas k ks ebm (accu, stack)\n | IBig_map_mem (_, k) ->\n let map, stack = stack in\n let key = accu in\n ( use_gas_counter_in_context ctxt gas @@ fun ctxt ->\n Script_big_map.mem ctxt key map )\n >>=? fun (res, ctxt, gas) ->\n (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack\n | IBig_map_get (_, k) ->\n let map, stack = stack in\n let key = accu in\n ( use_gas_counter_in_context ctxt gas @@ fun ctxt ->\n Script_big_map.get ctxt key map )\n >>=? fun (res, ctxt, gas) ->\n (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack\n | IBig_map_update (_, k) ->\n let key = accu in\n let maybe_value, (map, stack) = stack in\n ( use_gas_counter_in_context ctxt gas @@ fun ctxt ->\n Script_big_map.update ctxt key maybe_value map )\n >>=? fun (big_map, ctxt, gas) ->\n (step [@ocaml.tailcall]) (ctxt, sc) gas k ks big_map stack\n | IBig_map_get_and_update (_, k) ->\n let key = accu in\n let v, (map, stack) = stack in\n ( use_gas_counter_in_context ctxt gas @@ fun ctxt ->\n Script_big_map.get_and_update ctxt key v map )\n >>=? fun ((v', map'), ctxt, gas) ->\n (step [@ocaml.tailcall]) (ctxt, sc) gas k ks v' (map', stack)\n (* timestamp operations *)\n | IAdd_seconds_to_timestamp (_, k) ->\n let n = accu in\n let t, stack = stack in\n let result = Script_timestamp.add_delta t n in\n (step [@ocaml.tailcall]) g gas k ks result stack\n | IAdd_timestamp_to_seconds (_, k) ->\n let t = accu in\n let n, stack = stack in\n let result = Script_timestamp.add_delta t n in\n (step [@ocaml.tailcall]) g gas k ks result stack\n | ISub_timestamp_seconds (_, k) ->\n let t = accu in\n let s, stack = stack in\n let result = Script_timestamp.sub_delta t s in\n (step [@ocaml.tailcall]) g gas k ks result stack\n | IDiff_timestamps (_, k) ->\n let t1 = accu in\n let t2, stack = stack in\n let result = Script_timestamp.diff t1 t2 in\n (step [@ocaml.tailcall]) g gas k ks result stack\n (* string operations *)\n | IConcat_string_pair (_, k) ->\n let x = accu in\n let y, stack = stack in\n let s = Script_string.concat_pair x y in\n (step [@ocaml.tailcall]) g gas k ks s stack\n | IConcat_string (_, k) ->\n let ss = accu in\n (* The cost for this fold_left has been paid upfront *)\n let total_length =\n List.fold_left\n (fun acc s -> S.add acc (S.safe_int (Script_string.length s)))\n S.zero\n ss.elements\n in\n consume gas (Interp_costs.concat_string total_length)\n >>?= fun gas ->\n let s = Script_string.concat ss.elements in\n (step [@ocaml.tailcall]) g gas k ks s stack\n | ISlice_string (_, k) ->\n let offset = accu and length, (s, stack) = stack in\n let s_length = Z.of_int (Script_string.length s) in\n let offset = Script_int.to_zint offset in\n let length = Script_int.to_zint length in\n if Compare.Z.(offset < s_length && Z.add offset length <= s_length)\n then\n let s = Script_string.sub s (Z.to_int offset) (Z.to_int length) in\n (step [@ocaml.tailcall]) g gas k ks (Some s) stack\n else (step [@ocaml.tailcall]) g gas k ks None stack\n | IString_size (_, k) ->\n let s = accu in\n let result = Script_int.(abs (of_int (Script_string.length s))) in\n (step [@ocaml.tailcall]) g gas k ks result stack\n (* bytes operations *)\n | IConcat_bytes_pair (_, k) ->\n let x = accu in\n let y, stack = stack in\n let s = Bytes.cat x y in\n (step [@ocaml.tailcall]) g gas k ks s stack\n | IConcat_bytes (_, k) ->\n let ss = accu in\n (* The cost for this fold_left has been paid upfront *)\n let total_length =\n List.fold_left\n (fun acc s -> S.add acc (S.safe_int (Bytes.length s)))\n S.zero\n ss.elements\n in\n consume gas (Interp_costs.concat_string total_length)\n >>?= fun gas ->\n let s = Bytes.concat Bytes.empty ss.elements in\n (step [@ocaml.tailcall]) g gas k ks s stack\n | ISlice_bytes (_, k) ->\n let offset = accu and length, (s, stack) = stack in\n let s_length = Z.of_int (Bytes.length s) in\n let offset = Script_int.to_zint offset in\n let length = Script_int.to_zint length in\n if Compare.Z.(offset < s_length && Z.add offset length <= s_length)\n then\n let s = Bytes.sub s (Z.to_int offset) (Z.to_int length) in\n (step [@ocaml.tailcall]) g gas k ks (Some s) stack\n else (step [@ocaml.tailcall]) g gas k ks None stack\n | IBytes_size (_, k) ->\n let s = accu in\n let result = Script_int.(abs (of_int (Bytes.length s))) in\n (step [@ocaml.tailcall]) g gas k ks result stack\n | ILsl_bytes (loc, k) -> ilsl_bytes None g gas loc k ks accu stack\n | ILsr_bytes (_, k) ->\n let x = accu and y, stack = stack in\n let res = Script_bytes.bytes_lsr x y in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IOr_bytes (_, k) ->\n let x = accu and y, stack = stack in\n let res = Script_bytes.bytes_or x y in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IAnd_bytes (_, k) ->\n let x = accu and y, stack = stack in\n let res = Script_bytes.bytes_and x y in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IXor_bytes (_, k) ->\n let x = accu and y, stack = stack in\n let res = Script_bytes.bytes_xor x y in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | INot_bytes (_, k) ->\n let x = accu in\n let res = Script_bytes.bytes_not x in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IBytes_nat (_, k) ->\n let n = accu in\n let result = Script_bytes.bytes_of_nat_be n in\n (step [@ocaml.tailcall]) g gas k ks result stack\n | INat_bytes (_, k) ->\n let s = accu in\n let result = Script_bytes.nat_of_bytes_be s in\n (step [@ocaml.tailcall]) g gas k ks result stack\n | IBytes_int (_, k) ->\n let n = accu in\n let result = Script_bytes.bytes_of_int_be n in\n (step [@ocaml.tailcall]) g gas k ks result stack\n | IInt_bytes (_, k) ->\n let s = accu in\n let result = Script_bytes.int_of_bytes_be s in\n (step [@ocaml.tailcall]) g gas k ks result stack\n (* currency operations *)\n | IAdd_tez (_, k) ->\n let x = accu in\n let y, stack = stack in\n Tez.(x +? y) >>?= fun res ->\n (step [@ocaml.tailcall]) g gas k ks res stack\n | ISub_tez (_, k) ->\n let x = accu in\n let y, stack = stack in\n let res = Tez.sub_opt x y in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | ISub_tez_legacy (_, k) ->\n let x = accu in\n let y, stack = stack in\n Tez.(x -? y) >>?= fun res ->\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IMul_teznat (loc, k) -> imul_teznat None g gas loc k ks accu stack\n | IMul_nattez (loc, k) -> imul_nattez None g gas loc k ks accu stack\n (* boolean operations *)\n | IOr (_, k) ->\n let x = accu in\n let y, stack = stack in\n (step [@ocaml.tailcall]) g gas k ks (x || y) stack\n | IAnd (_, k) ->\n let x = accu in\n let y, stack = stack in\n (step [@ocaml.tailcall]) g gas k ks (x && y) stack\n | IXor (_, k) ->\n let x = accu in\n let y, stack = stack in\n let res = Compare.Bool.(x <> y) in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | INot (_, k) ->\n let x = accu in\n (step [@ocaml.tailcall]) g gas k ks (not x) stack\n (* integer operations *)\n | IIs_nat (_, k) ->\n let x = accu in\n let res = Script_int.is_nat x in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IAbs_int (_, k) ->\n let x = accu in\n let res = Script_int.abs x in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IInt_nat (_, k) ->\n let x = accu in\n let res = Script_int.int x in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | INeg (_, k) ->\n let x = accu in\n let res = Script_int.neg x in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IAdd_int (_, k) ->\n let x = accu and y, stack = stack in\n let res = Script_int.add x y in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IAdd_nat (_, k) ->\n let x = accu and y, stack = stack in\n let res = Script_int.add_n x y in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | ISub_int (_, k) ->\n let x = accu and y, stack = stack in\n let res = Script_int.sub x y in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IMul_int (_, k) ->\n let x = accu and y, stack = stack in\n let res = Script_int.mul x y in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IMul_nat (_, k) ->\n let x = accu and y, stack = stack in\n let res = Script_int.mul_n x y in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IEdiv_teznat (_, k) ->\n let x = accu and y, stack = stack in\n let x = Script_int.of_int64 (Tez.to_mutez x) in\n let result =\n match Script_int.ediv x y with\n | None -> None\n | Some (q, r) -> (\n match (Script_int.to_int64 q, Script_int.to_int64 r) with\n | Some q, Some r -> (\n match (Tez.of_mutez q, Tez.of_mutez r) with\n | Some q, Some r -> Some (q, r)\n (* Cannot overflow *)\n | _ -> assert false)\n (* Cannot overflow *)\n | _ -> assert false)\n in\n (step [@ocaml.tailcall]) g gas k ks result stack\n | IEdiv_tez (_, k) ->\n let x = accu and y, stack = stack in\n let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in\n let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in\n let result =\n match Script_int.ediv_n x y with\n | None -> None\n | Some (q, r) -> (\n match Script_int.to_int64 r with\n | None -> assert false (* Cannot overflow *)\n | Some r -> (\n match Tez.of_mutez r with\n | None -> assert false (* Cannot overflow *)\n | Some r -> Some (q, r)))\n in\n (step [@ocaml.tailcall]) g gas k ks result stack\n | IEdiv_int (_, k) ->\n let x = accu and y, stack = stack in\n let res = Script_int.ediv x y in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IEdiv_nat (_, k) ->\n let x = accu and y, stack = stack in\n let res = Script_int.ediv_n x y in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | ILsl_nat (loc, k) -> ilsl_nat None g gas loc k ks accu stack\n | ILsr_nat (loc, k) -> ilsr_nat None g gas loc k ks accu stack\n | IOr_nat (_, k) ->\n let x = accu and y, stack = stack in\n let res = Script_int.logor x y in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IAnd_nat (_, k) ->\n let x = accu and y, stack = stack in\n let res = Script_int.logand x y in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IAnd_int_nat (_, k) ->\n let x = accu and y, stack = stack in\n let res = Script_int.logand x y in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IXor_nat (_, k) ->\n let x = accu and y, stack = stack in\n let res = Script_int.logxor x y in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | INot_int (_, k) ->\n let x = accu in\n let res = Script_int.lognot x in\n (step [@ocaml.tailcall]) g gas k ks res stack\n (* control *)\n | IIf {branch_if_true; branch_if_false; k; _} ->\n let res, stack = stack in\n if accu then\n (step [@ocaml.tailcall])\n g\n gas\n branch_if_true\n (KCons (k, ks))\n res\n stack\n else\n (step [@ocaml.tailcall])\n g\n gas\n branch_if_false\n (KCons (k, ks))\n res\n stack\n | ILoop (_, body, k) ->\n let ks = KLoop_in (body, KCons (k, ks)) in\n (next [@ocaml.tailcall]) g gas ks accu stack\n | ILoop_left (_, bl, br) ->\n let ks = KLoop_in_left (bl, KCons (br, ks)) in\n (next [@ocaml.tailcall]) g gas ks accu stack\n | IDip (_, b, ty, k) ->\n let ign = accu in\n let ks = KUndip (ign, ty, KCons (k, ks)) in\n let accu, stack = stack in\n (step [@ocaml.tailcall]) g gas b ks accu stack\n | IExec (_, sty, k) -> iexec id None g gas sty k ks accu stack\n | IApply (_, capture_ty, k) ->\n let capture = accu in\n let lam, stack = stack in\n apply ctxt gas capture_ty capture lam >>=? fun (lam', ctxt, gas) ->\n (step [@ocaml.tailcall]) (ctxt, sc) gas k ks lam' stack\n | ILambda (_, lam, k) ->\n (step [@ocaml.tailcall]) g gas k ks lam (accu, stack)\n | IFailwith (kloc, tv) ->\n let {ifailwith} = ifailwith in\n ifailwith None g gas kloc tv accu\n (* comparison *)\n | ICompare (_, ty, k) ->\n let a = accu in\n let b, stack = stack in\n let r =\n Script_int.of_int @@ Script_comparable.compare_comparable ty a b\n in\n (step [@ocaml.tailcall]) g gas k ks r stack\n (* comparators *)\n | IEq (_, k) ->\n let a = accu in\n let a = Script_int.compare a Script_int.zero in\n let a = Compare.Int.(a = 0) in\n (step [@ocaml.tailcall]) g gas k ks a stack\n | INeq (_, k) ->\n let a = accu in\n let a = Script_int.compare a Script_int.zero in\n let a = Compare.Int.(a <> 0) in\n (step [@ocaml.tailcall]) g gas k ks a stack\n | ILt (_, k) ->\n let a = accu in\n let a = Script_int.compare a Script_int.zero in\n let a = Compare.Int.(a < 0) in\n (step [@ocaml.tailcall]) g gas k ks a stack\n | ILe (_, k) ->\n let a = accu in\n let a = Script_int.compare a Script_int.zero in\n let a = Compare.Int.(a <= 0) in\n (step [@ocaml.tailcall]) g gas k ks a stack\n | IGt (_, k) ->\n let a = accu in\n let a = Script_int.compare a Script_int.zero in\n let a = Compare.Int.(a > 0) in\n (step [@ocaml.tailcall]) g gas k ks a stack\n | IGe (_, k) ->\n let a = accu in\n let a = Script_int.compare a Script_int.zero in\n let a = Compare.Int.(a >= 0) in\n (step [@ocaml.tailcall]) g gas k ks a stack\n (* packing *)\n | IPack (_, ty, k) ->\n let value = accu in\n ( use_gas_counter_in_context ctxt gas @@ fun ctxt ->\n Script_ir_translator.pack_data ctxt ty value )\n >>=? fun (bytes, ctxt, gas) ->\n (step [@ocaml.tailcall]) (ctxt, sc) gas k ks bytes stack\n | IUnpack (_, ty, k) ->\n let bytes = accu in\n ( use_gas_counter_in_context ctxt gas @@ fun ctxt ->\n unpack ctxt ~ty ~bytes )\n >>=? fun (opt, ctxt, gas) ->\n (step [@ocaml.tailcall]) (ctxt, sc) gas k ks opt stack\n | IAddress (_, k) ->\n let typed_contract = accu in\n let destination = Typed_contract.destination typed_contract in\n let entrypoint = Typed_contract.entrypoint typed_contract in\n let address = {destination; entrypoint} in\n (step [@ocaml.tailcall]) g gas k ks address stack\n | IContract (loc, t, entrypoint, k) -> (\n let addr = accu in\n let entrypoint_opt =\n if Entrypoint.is_default addr.entrypoint then Some entrypoint\n else if Entrypoint.is_default entrypoint then Some addr.entrypoint\n else (* both entrypoints are non-default *) None\n in\n match entrypoint_opt with\n | Some entrypoint ->\n let ctxt = update_context gas ctxt in\n Script_ir_translator.parse_contract_for_script\n ctxt\n loc\n t\n addr.destination\n ~entrypoint\n >>=? fun (ctxt, maybe_contract) ->\n let gas, ctxt = local_gas_counter_and_outdated_context ctxt in\n let accu = maybe_contract in\n (step [@ocaml.tailcall]) (ctxt, sc) gas k ks accu stack\n | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack)\n | ITransfer_tokens (loc, k) ->\n let p = accu in\n let amount, (typed_contract, stack) = stack in\n transfer (ctxt, sc) gas amount loc typed_contract p\n >>=? fun (accu, ctxt, gas) ->\n (step [@ocaml.tailcall]) (ctxt, sc) gas k ks accu stack\n | IImplicit_account (_, k) ->\n let key = accu in\n let res = Typed_implicit key in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IView (_, view_signature, stack_ty, k) ->\n (iview [@ocaml.tailcall])\n id\n g\n gas\n view_signature\n stack_ty\n k\n ks\n accu\n stack\n | ICreate_contract {storage_type; code; k; loc = _} ->\n (* Removed the instruction's arguments manager, spendable and delegatable *)\n let delegate = accu in\n let credit, (init, stack) = stack in\n create_contract g gas storage_type code delegate credit init\n >>=? fun (res, contract, ctxt, gas) ->\n let destination = Destination.Contract (Originated contract) in\n let stack =\n ({destination; entrypoint = Entrypoint.default}, stack)\n in\n (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack\n | ISet_delegate (_, k) ->\n let delegate = accu in\n let operation = Delegation delegate in\n let ctxt = update_context gas ctxt in\n fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) ->\n let piop =\n Internal_operation\n {\n source = Destination.Contract (Contract.Originated sc.self);\n operation;\n nonce;\n }\n in\n let res = {piop; lazy_storage_diff = None} in\n let gas, ctxt = local_gas_counter_and_outdated_context ctxt in\n (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack\n | IBalance (_, k) ->\n let ctxt = update_context gas ctxt in\n let gas, ctxt = local_gas_counter_and_outdated_context ctxt in\n let g = (ctxt, sc) in\n (step [@ocaml.tailcall]) g gas k ks sc.balance (accu, stack)\n | ILevel (_, k) ->\n (step [@ocaml.tailcall]) g gas k ks sc.level (accu, stack)\n | INow (_, k) -> (step [@ocaml.tailcall]) g gas k ks sc.now (accu, stack)\n | IMin_block_time (_, k) ->\n let ctxt = update_context gas ctxt in\n let min_block_time =\n Alpha_context.Constants.minimal_block_delay ctxt\n |> Period.to_seconds |> Script_int.of_int64\n (* Realistically the block delay is never negative. *)\n |> Script_int.abs\n in\n let new_stack = (accu, stack) in\n (step [@ocaml.tailcall]) g gas k ks min_block_time new_stack\n | ICheck_signature (_, k) ->\n let key = accu and signature, (message, stack) = stack in\n let res = Script_signature.check key signature message in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IHash_key (_, k) ->\n let key = accu in\n let res = Signature.Public_key.hash key in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IBlake2b (_, k) ->\n let bytes = accu in\n let hash = Raw_hashes.blake2b bytes in\n (step [@ocaml.tailcall]) g gas k ks hash stack\n | ISha256 (_, k) ->\n let bytes = accu in\n let hash = Raw_hashes.sha256 bytes in\n (step [@ocaml.tailcall]) g gas k ks hash stack\n | ISha512 (_, k) ->\n let bytes = accu in\n let hash = Raw_hashes.sha512 bytes in\n (step [@ocaml.tailcall]) g gas k ks hash stack\n | ISource (_, k) ->\n let destination : Destination.t = Contract (Implicit sc.payer) in\n let res = {destination; entrypoint = Entrypoint.default} in\n (step [@ocaml.tailcall]) g gas k ks res (accu, stack)\n | ISender (_, k) ->\n let destination : Destination.t = sc.source in\n let res = {destination; entrypoint = Entrypoint.default} in\n (step [@ocaml.tailcall]) g gas k ks res (accu, stack)\n | ISelf (_, ty, entrypoint, k) ->\n let res =\n Typed_originated\n {arg_ty = ty; contract_hash = sc.self; entrypoint}\n in\n (step [@ocaml.tailcall]) g gas k ks res (accu, stack)\n | ISelf_address (_, k) ->\n let destination : Destination.t = Contract (Originated sc.self) in\n let res = {destination; entrypoint = Entrypoint.default} in\n (step [@ocaml.tailcall]) g gas k ks res (accu, stack)\n | IAmount (_, k) ->\n let accu = sc.amount and stack = (accu, stack) in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | IDig (_, _n, n', k) ->\n let (accu, stack), x =\n interp_stack_prefix_preserving_operation\n (fun v stack -> (stack, v))\n n'\n accu\n stack\n in\n let accu = x and stack = (accu, stack) in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | IDug (_, _n, n', k) ->\n let v = accu in\n let accu, stack = stack in\n let (accu, stack), () =\n interp_stack_prefix_preserving_operation\n (fun accu stack -> ((v, (accu, stack)), ()))\n n'\n accu\n stack\n in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | IDipn (_, _n, n', b, k) ->\n let accu, stack, restore_prefix = kundip n' accu stack k in\n let ks = KCons (restore_prefix, ks) in\n (step [@ocaml.tailcall]) g gas b ks accu stack\n | IDropn (_, _n, n', k) ->\n let stack =\n let rec aux :\n type a s b t.\n (b, t, b, t, a, s, a, s) stack_prefix_preservation_witness ->\n a ->\n s ->\n b * t =\n fun w accu stack ->\n match w with\n | KRest -> (accu, stack)\n | KPrefix (_, _ty, w) ->\n let accu, stack = stack in\n aux w accu stack\n in\n aux n' accu stack\n in\n let accu, stack = stack in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | ISapling_empty_state (_, memo_size, k) ->\n let state = Sapling.empty_state ~memo_size () in\n (step [@ocaml.tailcall]) g gas k ks state (accu, stack)\n | ISapling_verify_update (_, k) -> (\n let transaction = accu in\n let state, stack = stack in\n let address = Contract_hash.to_b58check sc.self in\n let sc_chain_id = Script_chain_id.make sc.chain_id in\n let chain_id = Script_chain_id.to_b58check sc_chain_id in\n let anti_replay = address ^ chain_id in\n let ctxt = update_context gas ctxt in\n Sapling.verify_update ctxt state transaction anti_replay\n >>=? fun (ctxt, balance_state_opt) ->\n let gas, ctxt = local_gas_counter_and_outdated_context ctxt in\n match balance_state_opt with\n | Some (balance, state) ->\n let state =\n Some\n ( Bytes.of_string transaction.bound_data,\n (Script_int.of_int64 balance, state) )\n in\n (step [@ocaml.tailcall]) (ctxt, sc) gas k ks state stack\n | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack)\n | ISapling_verify_update_deprecated (_, k) -> (\n let transaction = accu in\n let state, stack = stack in\n let address = Contract_hash.to_b58check sc.self in\n let sc_chain_id = Script_chain_id.make sc.chain_id in\n let chain_id = Script_chain_id.to_b58check sc_chain_id in\n let anti_replay = address ^ chain_id in\n let ctxt = update_context gas ctxt in\n Sapling.Legacy.verify_update ctxt state transaction anti_replay\n >>=? fun (ctxt, balance_state_opt) ->\n let gas, ctxt = local_gas_counter_and_outdated_context ctxt in\n match balance_state_opt with\n | Some (balance, state) ->\n let state = Some (Script_int.of_int64 balance, state) in\n (step [@ocaml.tailcall]) (ctxt, sc) gas k ks state stack\n | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack)\n | IChainId (_, k) ->\n let accu = Script_chain_id.make sc.chain_id\n and stack = (accu, stack) in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | INever _ -> ( match accu with _ -> .)\n | IVoting_power (_, k) ->\n let key_hash = accu in\n let ctxt = update_context gas ctxt in\n Vote.get_voting_power ctxt key_hash >>=? fun (ctxt, power) ->\n let power = Script_int.(abs (of_int64 power)) in\n let gas, ctxt = local_gas_counter_and_outdated_context ctxt in\n (step [@ocaml.tailcall]) (ctxt, sc) gas k ks power stack\n | ITotal_voting_power (_, k) ->\n let ctxt = update_context gas ctxt in\n Vote.get_total_voting_power ctxt >>=? fun (ctxt, power) ->\n let power = Script_int.(abs (of_int64 power)) in\n let gas, ctxt = local_gas_counter_and_outdated_context ctxt in\n let g = (ctxt, sc) in\n (step [@ocaml.tailcall]) g gas k ks power (accu, stack)\n | IKeccak (_, k) ->\n let bytes = accu in\n let hash = Raw_hashes.keccak256 bytes in\n (step [@ocaml.tailcall]) g gas k ks hash stack\n | ISha3 (_, k) ->\n let bytes = accu in\n let hash = Raw_hashes.sha3_256 bytes in\n (step [@ocaml.tailcall]) g gas k ks hash stack\n | IAdd_bls12_381_g1 (_, k) ->\n let x = accu and y, stack = stack in\n let accu = Script_bls.G1.add x y in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | IAdd_bls12_381_g2 (_, k) ->\n let x = accu and y, stack = stack in\n let accu = Script_bls.G2.add x y in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | IAdd_bls12_381_fr (_, k) ->\n let x = accu and y, stack = stack in\n let accu = Script_bls.Fr.add x y in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | IMul_bls12_381_g1 (_, k) ->\n let x = accu and y, stack = stack in\n let accu = Script_bls.G1.mul x y in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | IMul_bls12_381_g2 (_, k) ->\n let x = accu and y, stack = stack in\n let accu = Script_bls.G2.mul x y in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | IMul_bls12_381_fr (_, k) ->\n let x = accu and y, stack = stack in\n let accu = Script_bls.Fr.mul x y in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | IMul_bls12_381_fr_z (_, k) ->\n let x = accu and y, stack = stack in\n let x = Script_bls.Fr.of_z (Script_int.to_zint x) in\n let res = Script_bls.Fr.mul x y in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IMul_bls12_381_z_fr (_, k) ->\n let y = accu and x, stack = stack in\n let x = Script_bls.Fr.of_z (Script_int.to_zint x) in\n let res = Script_bls.Fr.mul x y in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | IInt_bls12_381_fr (_, k) ->\n let x = accu in\n let res = Script_int.of_zint (Script_bls.Fr.to_z x) in\n (step [@ocaml.tailcall]) g gas k ks res stack\n | INeg_bls12_381_g1 (_, k) ->\n let x = accu in\n let accu = Script_bls.G1.negate x in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | INeg_bls12_381_g2 (_, k) ->\n let x = accu in\n let accu = Script_bls.G2.negate x in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | INeg_bls12_381_fr (_, k) ->\n let x = accu in\n let accu = Script_bls.Fr.negate x in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | IPairing_check_bls12_381 (_, k) ->\n let pairs = accu in\n let check = Script_bls.pairing_check pairs.elements in\n (step [@ocaml.tailcall]) g gas k ks check stack\n | IComb (_, _, witness, k) ->\n let rec aux :\n type a b s c d t.\n (a, b, s, c, d, t) comb_gadt_witness ->\n a * (b * s) ->\n c * (d * t) =\n fun witness stack ->\n match (witness, stack) with\n | Comb_one, stack -> stack\n | Comb_succ witness', (a, tl) ->\n let b, tl' = aux witness' tl in\n ((a, b), tl')\n in\n let stack = aux witness (accu, stack) in\n let accu, stack = stack in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | IUncomb (_, _, witness, k) ->\n let rec aux :\n type a b s c d t.\n (a, b, s, c, d, t) uncomb_gadt_witness ->\n a * (b * s) ->\n c * (d * t) =\n fun witness stack ->\n match (witness, stack) with\n | Uncomb_one, stack -> stack\n | Uncomb_succ witness', ((a, b), tl) -> (a, aux witness' (b, tl))\n in\n let stack = aux witness (accu, stack) in\n let accu, stack = stack in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | IComb_get (_, _, witness, k) ->\n let comb = accu in\n let rec aux :\n type before after.\n (before, after) comb_get_gadt_witness -> before -> after =\n fun witness comb ->\n match (witness, comb) with\n | Comb_get_zero, v -> v\n | Comb_get_one, (a, _) -> a\n | Comb_get_plus_two witness', (_, b) -> aux witness' b\n in\n let accu = aux witness comb in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | IComb_set (_, _, witness, k) ->\n let value = accu and comb, stack = stack in\n let rec aux :\n type value before after.\n (value, before, after) comb_set_gadt_witness ->\n value ->\n before ->\n after =\n fun witness value item ->\n match (witness, item) with\n | Comb_set_zero, _ -> value\n | Comb_set_one, (_hd, tl) -> (value, tl)\n | Comb_set_plus_two witness', (hd, tl) ->\n (hd, aux witness' value tl)\n in\n let accu = aux witness value comb in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | IDup_n (_, _, witness, k) ->\n let rec aux :\n type a b before after.\n (a, b, before, after) dup_n_gadt_witness ->\n a * (b * before) ->\n after =\n fun witness stack ->\n match (witness, stack) with\n | Dup_n_zero, (a, _) -> a\n | Dup_n_succ witness', (_, tl) -> aux witness' tl\n in\n let stack = (accu, stack) in\n let accu = aux witness stack in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n (* Tickets *)\n | ITicket_deprecated (_, _, k) -> (\n let contents = accu and amount, stack = stack in\n match Ticket_amount.of_n amount with\n | Some amount ->\n let ticketer = Contract.Originated sc.self in\n let accu = {ticketer; contents; amount} in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | None -> tzfail Script_tc_errors.Forbidden_zero_ticket_quantity)\n | ITicket (_, _, k) -> (\n let contents = accu and amount, stack = stack in\n match Ticket_amount.of_n amount with\n | Some amount ->\n let ticketer = Contract.Originated sc.self in\n let accu = Some {ticketer; contents; amount} in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | None -> (step [@ocaml.tailcall]) g gas k ks None stack)\n | IRead_ticket (_, _, k) ->\n let {ticketer; contents; amount} = accu in\n let stack = (accu, stack) in\n let destination : Destination.t = Contract ticketer in\n let addr = {destination; entrypoint = Entrypoint.default} in\n let accu =\n (addr, (contents, (amount :> Script_int.n Script_int.num)))\n in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | ISplit_ticket (_, k) ->\n let ticket = accu and (amount_a, amount_b), stack = stack in\n let result =\n Option.bind (Ticket_amount.of_n amount_a) @@ fun amount_a ->\n Option.bind (Ticket_amount.of_n amount_b) @@ fun amount_b ->\n let amount = Ticket_amount.add amount_a amount_b in\n if\n Compare.Int.(\n Script_int.(\n compare (amount :> n num) (ticket.amount :> n num))\n = 0)\n then\n Some\n ( {ticket with amount = amount_a},\n {ticket with amount = amount_b} )\n else None\n in\n (step [@ocaml.tailcall]) g gas k ks result stack\n | IJoin_tickets (_, contents_ty, k) ->\n let ticket_a, ticket_b = accu in\n let result =\n if\n Compare.Int.(\n Contract.compare ticket_a.ticketer ticket_b.ticketer = 0\n && Script_comparable.compare_comparable\n contents_ty\n ticket_a.contents\n ticket_b.contents\n = 0)\n then\n Some\n {\n ticketer = ticket_a.ticketer;\n contents = ticket_a.contents;\n amount = Ticket_amount.add ticket_a.amount ticket_b.amount;\n }\n else None\n in\n (step [@ocaml.tailcall]) g gas k ks result stack\n | IOpen_chest (_, k) ->\n let open Timelock in\n let chest_key = accu in\n let chest, (time_z, stack) = stack in\n (* If the time is not an integer we then consider the proof as\n incorrect. Indeed the verification asks for an integer for practical reasons.\n Therefore no proof can be correct.*)\n let accu =\n match Script_int.to_int time_z with\n | None -> R false\n | Some time -> (\n match Script_timelock.open_chest chest chest_key ~time with\n | Correct bytes -> L bytes\n | Bogus_cipher -> R false\n | Bogus_opening -> R true)\n in\n (step [@ocaml.tailcall]) g gas k ks accu stack\n | IEmit {tag; ty = event_type; unparsed_ty; k; loc = _} ->\n let event_data = accu in\n emit_event (ctxt, sc) gas ~event_type ~unparsed_ty ~tag ~event_data\n >>=? fun (accu, ctxt, gas) ->\n (step [@ocaml.tailcall]) (ctxt, sc) gas k ks accu stack)\nend\n\nopen Raw\n\n(*\n\n Entrypoints\n ===========\n\n*)\n\nlet step_descr ~log_now logger (ctxt, sc) descr accu stack =\n let gas, outdated_ctxt = local_gas_counter_and_outdated_context ctxt in\n (match logger with\n | None -> step (outdated_ctxt, sc) gas descr.kinstr KNil accu stack\n | Some logger ->\n (if log_now then\n let loc = kinstr_location descr.kinstr in\n logger.log_interp descr.kinstr ctxt loc descr.kbef (accu, stack)) ;\n let log =\n ILog\n ( kinstr_location descr.kinstr,\n descr.kbef,\n LogEntry,\n logger,\n descr.kinstr )\n in\n let knil = KLog (KNil, descr.kaft, logger) in\n step (outdated_ctxt, sc) gas log knil accu stack)\n >>=? fun (accu, stack, ctxt, gas) ->\n return (accu, stack, update_context gas ctxt)\n\nlet interp logger g lam arg =\n match lam with\n | LamRec (code, _) ->\n step_descr ~log_now:true logger g code arg (lam, (EmptyCell, EmptyCell))\n >|=? fun (ret, (EmptyCell, EmptyCell), ctxt) -> (ret, ctxt)\n | Lam (code, _) ->\n step_descr ~log_now:true logger g code arg (EmptyCell, EmptyCell)\n >|=? fun (ret, (EmptyCell, EmptyCell), ctxt) -> (ret, ctxt)\n\n(*\n\n High-level functions\n ====================\n\n*)\ntype execution_arg =\n | Typed_arg :\n Script.location * ('a, _) Script_typed_ir.ty * 'a\n -> execution_arg\n | Untyped_arg : Script.expr -> execution_arg\n\nlet lift_execution_arg (type a ac) ctxt ~internal (entrypoint_ty : (a, ac) ty)\n (construct : a -> 'b) arg : ('b * context) tzresult Lwt.t =\n (match arg with\n | Untyped_arg arg ->\n let arg = Micheline.root arg in\n parse_data\n ctxt\n ~elab_conf:Script_ir_translator_config.(make ~legacy:false ())\n ~allow_forged:internal\n entrypoint_ty\n arg\n | Typed_arg (loc, parsed_arg_ty, parsed_arg) ->\n Gas_monad.run\n ctxt\n (Script_ir_translator.ty_eq\n ~error_details:(Informative loc)\n entrypoint_ty\n parsed_arg_ty)\n >>?= fun (res, ctxt) ->\n res >>?= fun Eq ->\n let parsed_arg : a = parsed_arg in\n return (parsed_arg, ctxt))\n >>=? fun (entrypoint_arg, ctxt) -> return (construct entrypoint_arg, ctxt)\n\ntype execution_result = {\n script : Script_ir_translator.ex_script;\n code_size : int;\n storage : Script.expr;\n lazy_storage_diff : Lazy_storage.diffs option;\n operations : packed_internal_operation list;\n ticket_diffs : Z.t Ticket_token_map.t;\n ticket_receipt : Ticket_receipt.t;\n}\n\nlet execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal\n unparsed_script cached_script arg =\n let elab_conf =\n Script_ir_translator_config.make\n ~legacy:true\n ~keep_extra_types_for_interpreter_logging:(Option.is_some logger)\n ()\n in\n (match cached_script with\n | None ->\n parse_script ctxt unparsed_script ~elab_conf ~allow_forged_in_storage:true\n | Some ex_script -> return (ex_script, ctxt))\n >>=? fun ( Ex_script\n (Script\n {\n code_size;\n code;\n arg_type;\n storage = old_storage;\n storage_type;\n entrypoints;\n views;\n }),\n ctxt ) ->\n Gas_monad.run\n ctxt\n (find_entrypoint\n ~error_details:(Informative ())\n arg_type\n entrypoints\n entrypoint)\n >>?= fun (r, ctxt) ->\n let self_contract = Contract.Originated step_constants.self in\n record_trace (Bad_contract_parameter self_contract) r\n >>?= fun (Ex_ty_cstr {ty = entrypoint_ty; construct; original_type_expr = _})\n ->\n trace\n (Bad_contract_parameter self_contract)\n (lift_execution_arg ctxt ~internal entrypoint_ty construct arg)\n >>=? fun (arg, ctxt) ->\n Script_ir_translator.collect_lazy_storage ctxt arg_type arg\n >>?= fun (to_duplicate, ctxt) ->\n Script_ir_translator.collect_lazy_storage ctxt storage_type old_storage\n >>?= fun (to_update, ctxt) ->\n trace\n (Runtime_contract_error step_constants.self)\n (interp logger (ctxt, step_constants) code (arg, old_storage))\n >>=? fun ((ops, new_storage), ctxt) ->\n Script_ir_translator.extract_lazy_storage_diff\n ctxt\n mode\n ~temporary:false\n ~to_duplicate\n ~to_update\n storage_type\n new_storage\n >>=? fun (storage, lazy_storage_diff, ctxt) ->\n trace Cannot_serialize_storage (unparse_data ctxt mode storage_type storage)\n >>=? fun (unparsed_storage, ctxt) ->\n let op_to_couple op = (op.piop, op.lazy_storage_diff) in\n let operations, op_diffs =\n ops.elements |> List.map op_to_couple |> List.split\n in\n let lazy_storage_diff_all =\n match\n List.flatten\n (List.map (Option.value ~default:[]) (op_diffs @ [lazy_storage_diff]))\n with\n | [] -> None\n | diff -> Some diff\n in\n let script =\n Ex_script\n (Script\n {code_size; code; arg_type; storage; storage_type; entrypoints; views})\n in\n Ticket_scanner.type_has_tickets ctxt arg_type\n >>?= fun (arg_type_has_tickets, ctxt) ->\n Ticket_scanner.type_has_tickets ctxt storage_type\n >>?= fun (storage_type_has_tickets, ctxt) ->\n (* Collect the ticket diffs *)\n Ticket_accounting.ticket_diffs\n ctxt\n ~self_contract\n ~arg_type_has_tickets\n ~storage_type_has_tickets\n ~arg\n ~old_storage\n ~new_storage\n ~lazy_storage_diff:(Option.value ~default:[] lazy_storage_diff)\n >>=? fun (ticket_diffs, ticket_receipt, ctxt) ->\n (* We consume gas after the fact in order to not have to instrument\n [script_size] (for efficiency).\n This is safe, as we already pay gas proportional to storage size\n in [unparse_data]. *)\n let size, cost = Script_ir_translator.script_size script in\n Gas.consume ctxt cost >>?= fun ctxt ->\n return\n ( {\n script;\n code_size = size;\n storage = unparsed_storage;\n lazy_storage_diff = lazy_storage_diff_all;\n operations;\n ticket_diffs;\n ticket_receipt;\n },\n ctxt )\n\nlet execute_with_typed_parameter ?logger ctxt ~cached_script mode step_constants\n ~script ~entrypoint ~parameter_ty ~location ~parameter ~internal =\n execute_any_arg\n logger\n ctxt\n mode\n step_constants\n ~entrypoint\n ~internal\n script\n cached_script\n (Typed_arg (location, parameter_ty, parameter))\n\nlet execute ?logger ctxt ~cached_script mode step_constants ~script ~entrypoint\n ~parameter ~internal =\n execute_any_arg\n logger\n ctxt\n mode\n step_constants\n ~entrypoint\n ~internal\n script\n cached_script\n (Untyped_arg parameter)\n\n(*\n\n Internals\n =========\n\n*)\n\n(*\n\n We export the internals definitions for tool that requires\n a white-box view on the interpreter, typically snoop, the\n gas model inference engine.\n\n*)\nmodule Internals = struct\n let next logger g gas sty ks accu stack =\n let ks =\n match logger with None -> ks | Some logger -> KLog (ks, sty, logger)\n in\n next g gas ks accu stack\n\n let kstep logger ctxt step_constants sty kinstr accu stack =\n let kinstr =\n match logger with\n | None -> kinstr\n | Some logger ->\n ILog (kinstr_location kinstr, sty, LogEntry, logger, kinstr)\n in\n let gas, outdated_ctxt = local_gas_counter_and_outdated_context ctxt in\n step (outdated_ctxt, step_constants) gas kinstr KNil accu stack\n >>=? fun (accu, stack, ctxt, gas) ->\n return (accu, stack, update_context gas ctxt)\n\n let step (ctxt, step_constants) gas ks accu stack =\n step (ctxt, step_constants) gas ks KNil accu stack\n\n let step_descr logger ctxt step_constants descr stack =\n step_descr ~log_now:false logger (ctxt, step_constants) descr stack\n\n module Raw = Raw\nend\n" ;
} ;
{ name = "Sc_rollup_management_protocol" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module provides a typed API for the Rollup Management Protocol that\n defines the communication protocol for exchanging messages between Layer 1\n and Layer 2 for smart-contract rollups.\n\n The API exposes functions for constructing inbox messages. These are\n messages produced by the Layer 1 protocol and added to a smart-contract\n rollups inbox.\n\n The Layer 2 node is responsible for decoding and interpreting the messages.\n\n A type {!outbox_message} representing messages from Layer 2 to Layer 1\n is also provided. An {!outbox_message} consists of a set of transactions\n to L1 accounts.\n *)\n\nopen Alpha_context\n\ntype error += (* Permanent *) Sc_rollup_invalid_destination\n\n(** A type representing a Layer 2 to Layer 1 transaction. *)\ntype transaction = private\n | Transaction : {\n destination : Contract_hash.t;\n entrypoint : Entrypoint.t;\n parameters_ty : ('a, _) Script_typed_ir.ty;\n parameters : 'a;\n unparsed_parameters : Script.expr;\n }\n -> transaction\n\n(** A type representing a batch of Layer 2 to Layer 1 transactions. *)\ntype atomic_transaction_batch = private {transactions : transaction list}\n\n(** A typed representation of {!Sc_rollup.Outbox.Message.t}. *)\ntype outbox_message = private\n | Atomic_transaction_batch of atomic_transaction_batch\n\n(** [make_internal_transfer ctxt ty ~payload ~sender ~source ~destination]\n constructs a smart rollup's [inbox message] (an L1 to L2 message)\n with the given [payload], [sender], and [source] targeting [destination]. *)\nval make_internal_transfer :\n context ->\n ('a, _) Script_typed_ir.ty ->\n payload:'a ->\n sender:Contract_hash.t ->\n source:public_key_hash ->\n destination:Sc_rollup.Address.t ->\n (Sc_rollup.Inbox_message.t * context) tzresult Lwt.t\n\n(** [outbox_message_of_outbox_message_repr ctxt msg] returns a typed version of\n of the given outbox message [msg].\n\n Fails with an [Sc_rollup_invalid_destination] error in case the parameters\n don't match the type of the entrypoint and destination. *)\nval outbox_message_of_outbox_message_repr :\n context ->\n Sc_rollup.Outbox.Message.t ->\n (outbox_message * context) tzresult Lwt.t\n\n(** Function for constructing and encoding {!inbox_message} and\n {!outbox_message} values. Since Layer 1 only ever consumes {!outbox_message}\n values and produces {!inbox_message} values, these functions are used for\n testing only. *)\nmodule Internal_for_tests : sig\n (** [make_transaction ctxt ty ~parameters ~destination ~entrypoint] creates a\n Layer 1 to Layer 2 transaction. *)\n val make_transaction :\n context ->\n ('a, _) Script_typed_ir.ty ->\n parameters:'a ->\n destination:Contract_hash.t ->\n entrypoint:Entrypoint.t ->\n (transaction * context) tzresult Lwt.t\n\n (** [make_atomic_batch ts] creates an atomic batch with the given\n transactions [ts]. *)\n val make_atomic_batch : transaction list -> outbox_message\n\n (** [serialize_output_message msg] encodes the outbox message [msg] in binary\n format. *)\n val serialize_outbox_message :\n outbox_message -> Sc_rollup.Outbox.Message.serialized tzresult\n\n (** [deserialize_inbox_message bs] decodes an inbox message from the given data\n [bs]. *)\n val deserialize_inbox_message :\n Sc_rollup.Inbox_message.serialized -> Sc_rollup.Inbox_message.t tzresult\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\ntype error += (* Permanent *) Sc_rollup_invalid_destination\n\nlet () =\n let open Data_encoding in\n let msg = \"Invalid destination\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_management_protocol_invalid_destination\"\n ~title:msg\n ~pp:(fun fmt () -> Format.fprintf fmt \"%s\" msg)\n ~description:msg\n unit\n (function Sc_rollup_invalid_destination -> Some () | _ -> None)\n (fun () -> Sc_rollup_invalid_destination)\n\ntype transaction =\n | Transaction : {\n destination : Contract_hash.t;\n entrypoint : Entrypoint.t;\n parameters_ty : ('a, _) Script_typed_ir.ty;\n parameters : 'a;\n unparsed_parameters : Script.expr;\n }\n -> transaction\n\ntype atomic_transaction_batch = {transactions : transaction list}\n\ntype outbox_message = Atomic_transaction_batch of atomic_transaction_batch\n\nlet make_internal_transfer ctxt ty ~payload ~sender ~source ~destination =\n let open Lwt_result_syntax in\n let+ payload, ctxt =\n Script_ir_translator.unparse_data\n ctxt\n Script_ir_unparser.Optimized\n ty\n payload\n in\n ( Sc_rollup.Inbox_message.Internal\n (Transfer {payload; sender; source; destination}),\n ctxt )\n\nlet transactions_batch_of_internal ctxt transactions =\n let open Lwt_result_syntax in\n let or_internal_transaction ctxt\n {Sc_rollup.Outbox.Message.unparsed_parameters; destination; entrypoint} =\n (* Lookup the contract-hash. *)\n (* Load the type and entrypoints of the script. *)\n let* ( Script_ir_translator.Ex_script (Script {arg_type; entrypoints; _}),\n ctxt ) =\n let* ctxt, _cache_key, cached = Script_cache.find ctxt destination in\n match cached with\n | Some (_script, ex_script) -> return (ex_script, ctxt)\n | None -> tzfail Sc_rollup_invalid_destination\n in\n (* Find the entrypoint type for the given entrypoint. *)\n let*? res, ctxt =\n Gas_monad.run\n ctxt\n (Script_ir_translator.find_entrypoint\n ~error_details:(Informative ())\n arg_type\n entrypoints\n entrypoint)\n in\n let*? (Ex_ty_cstr {ty = parameters_ty; _}) = res in\n (* Parse the parameters according to the entrypoint type. *)\n let* parameters, ctxt =\n Script_ir_translator.parse_data\n ctxt\n ~elab_conf:Script_ir_translator_config.(make ~legacy:false ())\n ~allow_forged:true\n parameters_ty\n (Micheline.root unparsed_parameters)\n in\n return\n ( Transaction\n {\n destination;\n entrypoint;\n parameters_ty;\n parameters;\n unparsed_parameters;\n },\n ctxt )\n in\n let+ ctxt, transactions =\n List.fold_left_map_es\n (fun ctxt msg ->\n let+ t, ctxt = or_internal_transaction ctxt msg in\n (ctxt, t))\n ctxt\n transactions\n in\n ({transactions}, ctxt)\n\nlet outbox_message_of_outbox_message_repr ctxt\n (Sc_rollup.Outbox.Message.Atomic_transaction_batch {transactions}) =\n let open Lwt_result_syntax in\n let+ ts, ctxt = transactions_batch_of_internal ctxt transactions in\n (Atomic_transaction_batch ts, ctxt)\n\nmodule Internal_for_tests = struct\n let make_transaction ctxt parameters_ty ~parameters ~destination ~entrypoint =\n let open Lwt_result_syntax in\n let* unparsed_parameters, ctxt =\n Script_ir_translator.unparse_data ctxt Optimized parameters_ty parameters\n in\n return\n ( Transaction\n {\n destination;\n entrypoint;\n parameters_ty;\n parameters;\n unparsed_parameters;\n },\n ctxt )\n\n let make_atomic_batch transactions = Atomic_transaction_batch {transactions}\n\n let serialize_outbox_message (Atomic_transaction_batch {transactions}) =\n let open Result_syntax in\n let to_internal_transaction\n (Transaction\n {\n destination;\n entrypoint;\n parameters_ty = _;\n parameters = _;\n unparsed_parameters;\n }) =\n return\n {Sc_rollup.Outbox.Message.unparsed_parameters; destination; entrypoint}\n in\n let* transactions = List.map_e to_internal_transaction transactions in\n let output_message_internal =\n Sc_rollup.Outbox.Message.Atomic_transaction_batch {transactions}\n in\n Sc_rollup.Outbox.Message.serialize output_message_internal\n\n let deserialize_inbox_message = Sc_rollup.Inbox_message.deserialize\nend\n" ;
} ;
{ name = "Sc_rollup_operations" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** High-level operations over smart contract rollups. *)\nopen Alpha_context\n\ntype error +=\n | (* Permanent *) Sc_rollup_invalid_parameters_type\n | (* Permanent *) Sc_rollup_invalid_last_cemented_commitment\n | (* Permanent *) Sc_rollup_invalid_output_proof\n | (* Permanent *) Sc_rollup_invalid_outbox_level\n\n(** Result of calling the {!execute_outbox_message} function. *)\ntype execute_outbox_message_result = {\n paid_storage_size_diff : Z.t;\n ticket_receipt : Ticket_receipt.t;\n operations : Script_typed_ir.packed_internal_operation list;\n}\n\ntype origination_result = {\n address : Sc_rollup.Address.t;\n size : Z.t;\n genesis_commitment_hash : Sc_rollup.Commitment.Hash.t;\n}\n\n(** [originate context ~kind ~boot_sector ~origination_proof\n ~parameters_ty] adds a new rollup running in a given [kind]\n initialized with a [boot_sector] and to accept smart contract\n calls of type [parameters_ty].\n\n [origination_proof], which covers the specialization of the PVM\n initial state with the [boot_sector], is used by the protocol to\n compute the genesis commitment, after its correctness has been\n checked.\n\n {b Note:} The need to provide an [origination_proof] is motivated\n by technical limitations of Irmin (as of June, 2022), that\n requires a context to get an empty tree. As soon as this\n limitation is lifted, then we can drop the [origination_proof]\n argument.\n\n Returns an error if [origination_proof] is invalid ({i e.g.}, it\n does not target the expected PVM).\n*)\nval originate :\n context ->\n kind:Sc_rollup.Kind.t ->\n boot_sector:string ->\n origination_proof:Sc_rollup.Proof.serialized ->\n parameters_ty:Script_repr.lazy_expr ->\n (origination_result * context) tzresult Lwt.t\n\n(** [execute_outbox_message ctxt rollup ~cemented_commitment\n ~output_proof] validates the given outbox message and prepares a\n set of resulting operations. *)\nval execute_outbox_message :\n context ->\n Sc_rollup.t ->\n cemented_commitment:Sc_rollup.Commitment.Hash.t ->\n output_proof:string ->\n (execute_outbox_message_result * context) tzresult Lwt.t\n\n(** A module used for testing purposes only. *)\nmodule Internal_for_tests : sig\n (** Same as {!execute_outbox_message} but allows overriding the extraction\n and validation of output proofs. *)\n val execute_outbox_message :\n context ->\n validate_and_decode_output_proof:\n (context ->\n cemented_commitment:Sc_rollup.Commitment.Hash.t ->\n Sc_rollup.t ->\n output_proof:string ->\n (Sc_rollup.output * context) tzresult Lwt.t) ->\n Sc_rollup.t ->\n cemented_commitment:Sc_rollup.Commitment.Hash.t ->\n output_proof:string ->\n (execute_outbox_message_result * context) tzresult Lwt.t\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 TriliTech <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\ntype error +=\n | (* Permanent *) Sc_rollup_invalid_parameters_type\n | (* Permanent *) Sc_rollup_invalid_last_cemented_commitment\n | (* Permanent *) Sc_rollup_invalid_output_proof\n | (* Permanent *) Sc_rollup_invalid_outbox_level\n\ntype execute_outbox_message_result = {\n paid_storage_size_diff : Z.t;\n ticket_receipt : Ticket_receipt.t;\n operations : Script_typed_ir.packed_internal_operation list;\n}\n\nlet () =\n let description = \"Invalid parameters type for smart rollup\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_invalid_parameters_type\"\n ~title:\"Invalid parameters type\"\n ~description\n ~pp:(fun fmt () -> Format.fprintf fmt \"%s\" description)\n Data_encoding.unit\n (function Sc_rollup_invalid_parameters_type -> Some () | _ -> None)\n (fun () -> Sc_rollup_invalid_parameters_type) ;\n let description = \"Invalid last-cemented-commitment\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_invalid_last_cemented_commitment\"\n ~title:description\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function\n | Sc_rollup_invalid_last_cemented_commitment -> Some () | _ -> None)\n (fun () -> Sc_rollup_invalid_last_cemented_commitment) ;\n let description = \"Invalid output proof\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_invalid_output_proof\"\n ~title:description\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Sc_rollup_invalid_output_proof -> Some () | _ -> None)\n (fun () -> Sc_rollup_invalid_output_proof) ;\n let description = \"Invalid outbox level\" in\n register_error_kind\n `Permanent\n ~id:\"smart_rollup_invalid_outbox_level\"\n ~title:description\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Sc_rollup_invalid_outbox_level -> Some () | _ -> None)\n (fun () -> Sc_rollup_invalid_outbox_level)\n\ntype origination_result = {\n address : Sc_rollup.Address.t;\n size : Z.t;\n genesis_commitment_hash : Sc_rollup.Commitment.Hash.t;\n}\n\ntype 'ret continuation = unit -> 'ret tzresult\n\n(* Only a subset of types are supported for rollups.\n This function checks whether or not a type can be used for a rollup. *)\nlet rec validate_ty :\n type a ac ret.\n (a, ac) Script_typed_ir.ty ->\n a Script_typed_ir.entrypoints_node ->\n ret continuation ->\n ret tzresult =\n fun ty {nested = nested_entrypoints; at_node} k ->\n let open Script_typed_ir in\n match at_node with\n | Some {name = _; original_type_expr = _} ->\n (* TODO: https://gitlab.com/tezos/tezos/-/issues/4023\n We currently don't support entrypoints as the entrypoint information\n for L1 to L2 messages is not propagated to the rollup. *)\n error Sc_rollup_invalid_parameters_type\n | None -> (\n match ty with\n (* Valid primitive types. *)\n | Unit_t -> (k [@ocaml.tailcall]) ()\n | Int_t -> (k [@ocaml.tailcall]) ()\n | Nat_t -> (k [@ocaml.tailcall]) ()\n | Signature_t -> (k [@ocaml.tailcall]) ()\n | String_t -> (k [@ocaml.tailcall]) ()\n | Bytes_t -> (k [@ocaml.tailcall]) ()\n | Key_hash_t -> (k [@ocaml.tailcall]) ()\n | Key_t -> (k [@ocaml.tailcall]) ()\n | Timestamp_t -> (k [@ocaml.tailcall]) ()\n | Address_t -> (k [@ocaml.tailcall]) ()\n | Bls12_381_g1_t -> (k [@ocaml.tailcall]) ()\n | Bls12_381_g2_t -> (k [@ocaml.tailcall]) ()\n | Bls12_381_fr_t -> (k [@ocaml.tailcall]) ()\n | Bool_t -> (k [@ocaml.tailcall]) ()\n | Never_t -> (k [@ocaml.tailcall]) ()\n | Tx_rollup_l2_address_t -> (k [@ocaml.tailcall]) ()\n | Chain_id_t -> (k [@ocaml.tailcall]) ()\n (* Valid collection types. *)\n | Ticket_t (ty, _) -> (validate_ty [@ocaml.tailcall]) ty no_entrypoints k\n | Set_t (ty, _) -> (validate_ty [@ocaml.tailcall]) ty no_entrypoints k\n | Option_t (ty, _, _) ->\n (validate_ty [@ocaml.tailcall]) ty no_entrypoints k\n | List_t (ty, _) -> (validate_ty [@ocaml.tailcall]) ty no_entrypoints k\n | Pair_t (ty1, ty2, _, _) ->\n (* Entrypoints may not be nested in pairs, hence the no_entrypoints\n value. *)\n (validate_two_tys [@ocaml.tailcall])\n ty1\n ty2\n no_entrypoints\n no_entrypoints\n k\n | Union_t (ty1, ty2, _, _) ->\n let entrypoints_l, entrypoints_r =\n match nested_entrypoints with\n | Entrypoints_None -> (no_entrypoints, no_entrypoints)\n | Entrypoints_Union {left; right} -> (left, right)\n in\n (validate_two_tys [@ocaml.tailcall])\n ty1\n ty2\n entrypoints_l\n entrypoints_r\n k\n | Map_t (key_ty, val_ty, _) ->\n (* Entrypoints may not be nested in maps, hence the no_entrypoints\n value. *)\n (validate_two_tys [@ocaml.tailcall])\n key_ty\n val_ty\n no_entrypoints\n no_entrypoints\n k\n (* Invalid types. *)\n | Mutez_t -> error Sc_rollup_invalid_parameters_type\n | Big_map_t (_key_ty, _val_ty, _) ->\n error Sc_rollup_invalid_parameters_type\n | Contract_t _ -> error Sc_rollup_invalid_parameters_type\n | Sapling_transaction_t _ -> error Sc_rollup_invalid_parameters_type\n | Sapling_transaction_deprecated_t _ ->\n error Sc_rollup_invalid_parameters_type\n | Sapling_state_t _ -> error Sc_rollup_invalid_parameters_type\n | Operation_t -> error Sc_rollup_invalid_parameters_type\n | Chest_t -> error Sc_rollup_invalid_parameters_type\n | Chest_key_t -> error Sc_rollup_invalid_parameters_type\n | Lambda_t (_, _, _) -> error Sc_rollup_invalid_parameters_type)\n\nand validate_two_tys :\n type a ac b bc ret.\n (a, ac) Script_typed_ir.ty ->\n (b, bc) Script_typed_ir.ty ->\n a Script_typed_ir.entrypoints_node ->\n b Script_typed_ir.entrypoints_node ->\n ret continuation ->\n ret tzresult =\n fun ty1 ty2 entrypoints1 entrypoints2 k ->\n (validate_ty [@ocaml.tailcall]) ty1 entrypoints1 (fun () ->\n (validate_ty [@ocaml.tailcall]) ty2 entrypoints2 k)\n\nlet validate_parameters_ty :\n type a ac.\n context ->\n (a, ac) Script_typed_ir.ty ->\n a Script_typed_ir.entrypoints_node ->\n context tzresult =\n fun ctxt parameters_ty entrypoints ->\n let open Result_syntax in\n let* ctxt =\n Gas.consume\n ctxt\n (Sc_rollup_costs.is_valid_parameters_ty_cost\n ~ty_size:Script_typed_ir.(ty_size parameters_ty |> Type_size.to_int))\n in\n let+ () = validate_ty parameters_ty entrypoints ok in\n ctxt\n\nlet validate_untyped_parameters_ty ctxt parameters_ty =\n let open Result_syntax in\n (* Parse the type and check that the entrypoints are well-formed. Using\n [parse_parameter_ty_and_entrypoints] restricts to [passable] types\n (everything but operations), which is OK since [validate_ty] constraints\n the type further. *)\n let* ( Ex_parameter_ty_and_entrypoints\n {\n arg_type;\n entrypoints =\n {Script_typed_ir.root = entrypoint; original_type_expr = _};\n },\n ctxt ) =\n Script_ir_translator.parse_parameter_ty_and_entrypoints\n ctxt\n ~legacy:false\n (Micheline.root parameters_ty)\n in\n (* TODO: https://gitlab.com/tezos/tezos/-/issues/4023\n We currently don't support entrypoints as the entrypoint information\n for L1 to L2 messages is not propagated to the rollup. *)\n validate_parameters_ty ctxt arg_type entrypoint\n\nlet check_origination_proof (type state proof output)\n ~(pvm : (state, proof, output) Sc_rollup.PVM.implementation) boot_sector\n origination_proof =\n let open Lwt_result_syntax in\n let (module PVM) = pvm in\n let*! is_valid = PVM.verify_origination_proof origination_proof boot_sector in\n let* () =\n fail_when\n (not is_valid)\n (Sc_rollup_proof_repr.Sc_rollup_proof_check \"invalid origination proof\")\n in\n return PVM.(proof_stop_state origination_proof)\n\nlet originate ctxt ~kind ~boot_sector ~origination_proof ~parameters_ty =\n let open Lwt_result_syntax in\n let (Packed ((module PVM) as pvm)) = Sc_rollup.Kind.pvm_of kind in\n let*? ctxt =\n let open Result_syntax in\n let* parameters_ty, ctxt =\n Script.force_decode_in_context\n ~consume_deserialization_gas:When_needed\n ctxt\n parameters_ty\n in\n validate_untyped_parameters_ty ctxt parameters_ty\n in\n let*? origination_proof =\n Sc_rollup.Proof.unserialize_pvm_step ~pvm origination_proof\n in\n let* genesis_hash =\n check_origination_proof ~pvm boot_sector origination_proof\n in\n let genesis_commitment =\n Sc_rollup.Commitment.genesis_commitment\n ~genesis_state_hash:genesis_hash\n ~origination_level:(Level.current ctxt).level\n in\n let+ address, size, genesis_commitment_hash, ctxt =\n Sc_rollup.originate ctxt ~kind ~parameters_ty ~genesis_commitment\n in\n ({address; size; genesis_commitment_hash}, ctxt)\n\nlet to_transaction_operation ctxt rollup\n (Sc_rollup_management_protocol.Transaction\n {destination; entrypoint; parameters_ty; parameters; unparsed_parameters})\n =\n let open Result_syntax in\n let* ctxt, nonce = fresh_internal_nonce ctxt in\n (* Validate the type of the parameters. Only types that can be transferred\n from Layer 1 to Layer 2 are permitted.\n\n In principle, we could allow different types to be passed to the rollup and\n from the rollup. In order to avoid confusion, and given that we don't\n have any use case where they differ, we keep these sets identical.\n\n We don't check whether the type contains any entrypoints at this stage.\n It has already been done during origination.\n *)\n let* ctxt =\n validate_parameters_ty ctxt parameters_ty Script_typed_ir.no_entrypoints\n in\n let operation =\n Script_typed_ir.Transaction_to_smart_contract\n {\n destination;\n amount = Tez.zero;\n entrypoint;\n location = Micheline.dummy_location;\n parameters_ty;\n parameters;\n unparsed_parameters;\n }\n in\n return\n ( Script_typed_ir.Internal_operation\n {source = Destination.Sc_rollup rollup; operation; nonce},\n ctxt )\n\n(* Transfer some ticket-tokens from [source_destination] to [target_destination].\n This operation fails in case the [source_destination]'s balance is lower than\n amount. *)\nlet transfer_ticket_token ctxt ~source_destination ~target_destination ~amount\n ticket_token =\n let open Lwt_result_syntax in\n let* source_key_hash, ctxt =\n Ticket_balance_key.of_ex_token ctxt ~owner:source_destination ticket_token\n in\n let* target_key_hash, ctxt =\n Ticket_balance_key.of_ex_token ctxt ~owner:target_destination ticket_token\n in\n let* source_storage_diff, ctxt =\n Ticket_balance.adjust_balance ctxt source_key_hash ~delta:(Z.neg amount)\n in\n let* target_storage_diff, ctxt =\n Ticket_balance.adjust_balance ctxt target_key_hash ~delta:amount\n in\n (* Adjust the recorded paid-for storage space for the ticket-table. *)\n let* storage_diff_to_pay, ctxt =\n Ticket_balance.adjust_storage_space\n ctxt\n ~storage_diff:(Z.add source_storage_diff target_storage_diff)\n in\n return (storage_diff_to_pay, ctxt)\n\nlet transfer_ticket_tokens ctxt ~source_destination ~acc_storage_diff\n {Ticket_operations_diff.ticket_token; total_amount = _; destinations} =\n let open Lwt_result_syntax in\n List.fold_left_es\n (fun (acc_storage_diff, ctxt)\n (target_destination, (amount : Script_typed_ir.ticket_amount)) ->\n let* storage_diff, ctxt =\n transfer_ticket_token\n ctxt\n ~source_destination\n ~target_destination\n ~amount:Script_int.(to_zint (amount :> n num))\n ticket_token\n in\n return (Z.(add acc_storage_diff storage_diff), ctxt))\n (acc_storage_diff, ctxt)\n destinations\n\nlet validate_and_decode_output_proof ctxt ~cemented_commitment rollup\n ~output_proof =\n let open Lwt_result_syntax in\n (* Lookup the PVM of the rollup. *)\n let* ctxt, Packed (module PVM) =\n let+ ctxt, kind = Sc_rollup.kind ctxt rollup in\n (ctxt, Sc_rollup.Kind.pvm_of kind)\n in\n let output_proof_length = String.length output_proof in\n let*? ctxt =\n Gas.consume\n ctxt\n (Sc_rollup_costs.cost_deserialize_output_proof\n ~bytes_len:output_proof_length)\n in\n let*? output_proof =\n match\n Data_encoding.Binary.of_string_opt PVM.output_proof_encoding output_proof\n with\n | Some x -> ok x\n | None -> error Sc_rollup_invalid_output_proof\n in\n let output = PVM.output_of_output_proof output_proof in\n (* Verify that the states match. *)\n let* {Sc_rollup.Commitment.compressed_state; _}, ctxt =\n Sc_rollup.Commitment.get_commitment ctxt rollup cemented_commitment\n in\n let* () =\n let output_proof_state = PVM.state_of_output_proof output_proof in\n fail_unless\n Sc_rollup.State_hash.(output_proof_state = compressed_state)\n Sc_rollup_invalid_output_proof\n in\n (* Consume cost of output proof verification. *)\n let*? ctxt =\n Gas.consume\n ctxt\n (Sc_rollup_costs.cost_verify_output_proof ~bytes_len:output_proof_length)\n in\n (* Verify that the proof is valid. *)\n let* () =\n let*! proof_is_valid = PVM.verify_output_proof output_proof in\n fail_unless proof_is_valid Sc_rollup_invalid_output_proof\n in\n return (output, ctxt)\n\nlet validate_outbox_level ctxt ~outbox_level ~lcc_level =\n (* Check that outbox level is within the bounds of:\n [min_level < outbox_level <= lcc_level]\n Where\n [min_level = lcc_level - max_active_levels]\n\n This prevents the rollup from putting messages at a level that is greater\n than its corresponding inbox-level. It also prevents execution\n of messages that are older than the maximum number of active levels.\n *)\n let max_active_levels =\n Int32.to_int (Constants.sc_rollup_max_active_outbox_levels ctxt)\n in\n let outbox_level_is_active =\n let min_allowed_level =\n Int32.sub (Raw_level.to_int32 lcc_level) (Int32.of_int max_active_levels)\n in\n Compare.Int32.(min_allowed_level < Raw_level.to_int32 outbox_level)\n in\n fail_unless\n (Raw_level.(outbox_level <= lcc_level) && outbox_level_is_active)\n Sc_rollup_invalid_outbox_level\n\nlet execute_outbox_message ctxt ~validate_and_decode_output_proof rollup\n ~cemented_commitment ~output_proof =\n let open Lwt_result_syntax in\n (* Get inbox level of last cemented commitment, needed to validate that the\n outbox message is active. This call also implicitly checks that the rollup\n exists. *)\n let* lcc_hash, lcc_level, ctxt =\n Sc_rollup.Commitment.last_cemented_commitment_hash_with_level ctxt rollup\n in\n (* Check that the commitment is a cemented commitment still stored in the\n context. We start from the [lcc_hash] of the rollup, which we know to be\n stored in context. *)\n let* is_cemented_commitment_in_context, ctxt =\n Sc_rollup.Commitment.check_if_commitments_are_related\n ctxt\n rollup\n ~descendant:lcc_hash\n ~ancestor:cemented_commitment\n in\n let* () =\n fail_unless\n is_cemented_commitment_in_context\n Sc_rollup_invalid_last_cemented_commitment\n in\n (* Validate and decode the output proofs. *)\n let* Sc_rollup.{outbox_level; message_index; message}, ctxt =\n validate_and_decode_output_proof\n ctxt\n ~cemented_commitment\n rollup\n ~output_proof\n in\n (* Validate that the outbox level is within valid bounds. *)\n let* () = validate_outbox_level ctxt ~outbox_level ~lcc_level in\n let* ( Sc_rollup_management_protocol.Atomic_transaction_batch {transactions},\n ctxt ) =\n Sc_rollup_management_protocol.outbox_message_of_outbox_message_repr\n ctxt\n message\n in\n (* Turn the transaction batch into a list of operations. *)\n let*? ctxt, operations =\n List.fold_left_map_e\n (fun ctxt transaction ->\n let open Result_syntax in\n let+ op, ctxt = to_transaction_operation ctxt rollup transaction in\n (ctxt, op))\n ctxt\n transactions\n in\n (* Record that the message for the given level has been applied. This fails\n in case a message for the rollup, outbox-level and message index has\n already been executed. The storage diff returned may be negative.\n *)\n let* applied_msg_size_diff, ctxt =\n Sc_rollup.Outbox.record_applied_message\n ctxt\n rollup\n outbox_level\n ~message_index:(Z.to_int message_index)\n in\n (* TODO: #3121\n Implement a more refined model. For instance a water-mark based one.\n For now we only charge for positive contributions. It means that over time\n we are overcharging for storage space.\n *)\n let paid_storage_size_diff = Z.max Z.zero applied_msg_size_diff in\n (* Extract the ticket-token diffs from the operations. We here make sure that\n there are no tickets with amount zero. Zero-amount tickets are not allowed\n as they cannot be tracked by the ticket-balance table.\n *)\n let* ticket_token_diffs, ctxt =\n Ticket_operations_diff.ticket_diffs_of_operations ctxt operations\n in\n (* Update the ticket-balance table by transferring ticket-tokens to new\n destinations for each transaction. This fails in case the rollup does not\n hold a sufficient amount of any of the ticket-tokens transferred.\n\n The updates must happen before any of the operations are executed to avoid\n a case where ticket-transfers are funded as a result of prior operations\n depositing new tickets to the rollup.\n *)\n let* paid_storage_size_diff, ctxt =\n let source_destination = Destination.Sc_rollup rollup in\n List.fold_left_es\n (fun (acc_storage_diff, ctxt) ticket_token_diff ->\n transfer_ticket_tokens\n ctxt\n ~source_destination\n ~acc_storage_diff\n ticket_token_diff)\n (paid_storage_size_diff, ctxt)\n ticket_token_diffs\n in\n let* ctxt, ticket_receipt =\n List.fold_left_map_es\n (fun ctxt\n Ticket_operations_diff.\n {ticket_token = ex_token; total_amount; destinations = _} ->\n let+ ticket_token, ctxt = Ticket_token_unparser.unparse ctxt ex_token in\n (* Here we only show the outgoing (negative) balance wrt to the rollup\n address. The positive balances for the receiving contracts are\n contained in the ticket updates for the internal operations. *)\n let item =\n Ticket_receipt.\n {\n ticket_token;\n updates =\n [\n {\n account = Destination.Sc_rollup rollup;\n amount = Z.neg (Script_int.to_zint total_amount);\n };\n ];\n }\n in\n (ctxt, item))\n ctxt\n ticket_token_diffs\n in\n return ({paid_storage_size_diff; ticket_receipt; operations}, ctxt)\n\nmodule Internal_for_tests = struct\n let execute_outbox_message = execute_outbox_message\nend\n\nlet execute_outbox_message ctxt =\n execute_outbox_message ctxt ~validate_and_decode_output_proof\n" ;
} ;
{ name = "Dal_apply" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This modules handles all the validation/application/finalisation\n of any operation related to the DAL. *)\n\nopen Alpha_context\n\n(** [validate_attestation ctxt op] ensures that [op.attestation] is\n valid and cannot prevent an operation containing [op.attestation]\n to be refused on top of [ctxt]. If an [Error _] is returned, the\n [op.attestation] is not valid. *)\nval validate_attestation : t -> Dal.Attestation.operation -> unit tzresult\n\n(** [apply_attestation ctxt op] applies [op.attestation] into the\n [ctxt] assuming [op.attestor] issued those attestations. *)\nval apply_attestation : t -> Dal.Attestation.operation -> t tzresult\n\n(** [validate_publish_slot_header ctxt slot] ensures that [slot_header] is\n valid and cannot prevent an operation containing [slot_header] to be\n refused on top of [ctxt]. If an [Error _] is returned, the [slot_header]\n is not valid. *)\nval validate_publish_slot_header :\n t -> Dal.Slot.Header.operation -> unit tzresult\n\n(** [apply_publish_slot_header ctxt slot_header] applies the publication of\n slot header [slot_header] on top of [ctxt]. Fails if the slot contains\n already a slot header. *)\nval apply_publish_slot_header : t -> Dal.Slot.Header.operation -> t tzresult\n\n(** [finalisation ctxt] should be executed at block finalisation\n time. A set of slots attested at level [ctxt.current_level - lag]\n is returned encapsulated into the attestation data-structure.\n\n [lag] is a parametric constant specific to the data-availability\n layer. *)\nval finalisation : t -> (t * Dal.Attestation.t option) tzresult Lwt.t\n\n(** [initialize ctxt ~level] should be executed at block\n initialisation time. It allows to cache the committee for [level]\n in memory so that every time we need to use this committee, there\n is no need to recompute it again. *)\nval initialisation : t -> level:Level.t -> t tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(* Every function of this file should check the feature flag. *)\n\nopen Alpha_context\nopen Dal_errors\n\nlet assert_dal_feature_enabled ctxt =\n let open Constants in\n let Parametric.{dal = {feature_enable; _}; _} = parametric ctxt in\n error_unless Compare.Bool.(feature_enable = true) Dal_feature_disabled\n\nlet only_if_dal_feature_enabled ctxt ~default f =\n let open Constants in\n let Parametric.{dal = {feature_enable; _}; _} = parametric ctxt in\n if feature_enable then f ctxt else default ctxt\n\nlet slot_of_int_e n =\n let open Result_syntax in\n match Dal.Slot_index.of_int n with\n | None -> tzfail Dal_errors.Dal_slot_index_above_hard_limit\n | Some slot_index -> return slot_index\n\nlet validate_attestation ctxt op =\n assert_dal_feature_enabled ctxt >>? fun () ->\n let open Result_syntax in\n (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/4163\n check the signature of the attestor as well *)\n let Dal.Attestation.{attestor = _; attestation; level = given} = op in\n let* max_index =\n slot_of_int_e @@ ((Constants.parametric ctxt).dal.number_of_slots - 1)\n in\n let maximum_size = Dal.Attestation.expected_size_in_bits ~max_index in\n let size = Dal.Attestation.occupied_size_in_bits attestation in\n let* () =\n error_unless\n Compare.Int.(size <= maximum_size)\n (Dal_attestation_size_limit_exceeded {maximum_size; got = size})\n in\n let current = Level.(current ctxt).level in\n let delta_levels = Raw_level.diff current given in\n let* () =\n error_when\n Compare.Int32.(delta_levels > 0l)\n (Dal_operation_for_old_level {current; given})\n in\n error_when\n Compare.Int32.(delta_levels < 0l)\n (Dal_operation_for_future_level {current; given})\n\nlet apply_attestation ctxt op =\n assert_dal_feature_enabled ctxt >>? fun () ->\n let Dal.Attestation.{attestor; attestation; level = _} = op in\n match Dal.Attestation.shards_of_attestor ctxt ~attestor with\n | None ->\n let level = Level.current ctxt in\n error (Dal_data_availibility_attestor_not_in_committee {attestor; level})\n | Some shards ->\n Ok (Dal.Attestation.record_available_shards ctxt attestation shards)\n\nlet validate_publish_slot_header ctxt operation =\n assert_dal_feature_enabled ctxt >>? fun () ->\n let open Result_syntax in\n let open Constants in\n let Dal.Slot.Header.{id = {index; published_level}; _} =\n operation.Dal.Slot.Header.header\n in\n let Parametric.{dal = {number_of_slots; cryptobox_parameters; _}; _} =\n parametric ctxt\n in\n let* number_of_slots = slot_of_int_e (number_of_slots - 1) in\n let* () =\n error_unless\n Compare.Int.(\n Dal.Slot_index.compare index number_of_slots <= 0\n && Dal.Slot_index.compare index Dal.Slot_index.zero >= 0)\n (Dal_publish_slot_header_invalid_index\n {given = index; maximum = number_of_slots})\n in\n let current_level = (Level.current ctxt).level in\n let* () =\n error_when\n Raw_level.(current_level < published_level)\n (Dal_publish_slot_header_future_level\n {provided = published_level; expected = current_level})\n in\n let* () =\n error_when\n Raw_level.(current_level > published_level)\n (Dal_publish_slot_header_past_level\n {provided = published_level; expected = current_level})\n in\n let* proof_ok =\n Dal.Slot.Header.verify_commitment cryptobox_parameters operation\n in\n error_unless\n proof_ok\n (Dal_publish_slot_header_invalid_proof {slot_header = operation})\n\nlet apply_publish_slot_header ctxt operation =\n assert_dal_feature_enabled ctxt >>? fun () ->\n Dal.Slot.register_slot_header ctxt operation.Dal.Slot.Header.header\n >>? fun (ctxt, updated) ->\n if updated then ok ctxt\n else\n error (Dal_publish_slot_header_duplicate {slot_header = operation.header})\n\nlet finalisation ctxt =\n only_if_dal_feature_enabled\n ctxt\n ~default:(fun ctxt -> return (ctxt, None))\n (fun ctxt ->\n Dal.Slot.finalize_current_slot_headers ctxt >>= fun ctxt ->\n (* The fact that slots confirmation is done at finalization is very\n important for the assumptions made by the Dal refutation game. In fact:\n - {!Dal.Slot.finalize_current_slot_headers} updates the Dal skip list\n at block finalization, by inserting newly confirmed slots;\n - {!Sc_rollup.Game.initial}, called when applying a manager operation\n that starts a refutation game, makes a snapshot of the Dal skip list\n to use it as a reference if the refutation proof involves a Dal input.\n\n If confirmed Dal slots are inserted into the skip list during operations\n application, adapting how refutation games are made might be needed\n to e.g.,\n - use the same snapshotted skip list as a reference by L1 and rollup-node;\n - disallow proofs involving pages of slots that have been confirmed at the\n level where the game started.\n *)\n Dal.Slot.finalize_pending_slot_headers ctxt\n >|=? fun (ctxt, attestation) -> (ctxt, Some attestation))\n\nlet initialisation ctxt ~level =\n let open Lwt_result_syntax in\n only_if_dal_feature_enabled\n ctxt\n ~default:(fun ctxt -> return ctxt)\n (fun ctxt ->\n let pkh_from_tenderbake_slot slot =\n Stake_distribution.slot_owner ctxt level slot\n >|=? fun (ctxt, consensus_pk1) -> (ctxt, consensus_pk1.delegate)\n in\n (* This committee is cached because it is the one we will use\n for the validation of the DAL attestations. *)\n let* committee =\n Alpha_context.Dal.Attestation.compute_committee\n ctxt\n pkh_from_tenderbake_slot\n in\n return (Alpha_context.Dal.Attestation.init_committee ctxt committee))\n" ;
} ;
{ name = "Zk_rollup_apply" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module handles all the validation/application of any operation\n related to the ZK Rollup.\n All of the functions defined in this module require that the ZKRU\n feature flag is enabled.\n*)\n\n(** In the ZK Rollup, L2 operations are validated in two steps:\n {ol\n {li The Protocol does the first pass of (light) validation and\n appends the L2 operation to a pending list.}\n {li The ZKRU Operator does the second pass of validation for a prefix\n of the pending list and posts a proof on chain of the validity of\n each of them.\n Based on this proof, the Protocol is going to remove the prefix\n from the pending list, and apply their effect on the ZKRU L2 state\n and on the L1 balances.}\n }\n\n The first step of validation is split into two cases, depending on\n the type of L2 operation that is being submitted:\n {ul\n {li If the application of said L2 operation results in a transfer\n of a ticket from L1 to L2 (i.e. it is a ZKRU {i deposit}), the\n L2 operation has to be submitted through a call to the ZKRU\n [%deposit] entrypoint from a smart contract.\n This constraint is imposed by the fact that implicit accounts\n cannot transfer tickets.\n Then, the validation of these L2 operations will be performed\n when applying the internal Tezos operation emitted by the call\n to the ZKRU's deposit entrypoint. This is implemented by the\n [transaction_to_zk_rollup] function in this module.\n }\n {li If its application results in a ticket transfer from L2 to L1\n (i.e. it is a ZKRU {i withdrawal}) or it has no transfer between\n layers, the L2 operation has to be submitted through a\n [Zk_rollup_publish] external Tezos operation.\n The checks for these L2 operations will be perform upon application\n of said external Tezos operation, whose logic is implemented by the\n [publish] function in this module.\n }\n }\n\n Although L2 operations are mostly opaque, they expose a header that is\n transparent to the Protocol (see {!Zk_rollup_operation_repr.t}).\n In this header there's a field for the [price] of an L2 operation, which\n will expose its kind. Concretely, the [price] encodes the net ticket\n transfer from L1 to L2 caused by an L2 operation. Then, deposits have\n a positive price, withdrawals a negative one, and pure L2 operations\n must have a price of zero.\n\n An L2 operation's price also encodes which ticket is being transferred,\n by storing the ticket's hash (see {!Ticket_hash_repr}). These hashes are\n used as token identifiers inside the ZKRU. In both cases, the L2 operations\n with a non-zero price (i.e. deposits and withdrawals) will be submitted\n alongside the values describing the ticket being transferred\n (see {!Zk_rollup_ticket_repr}). These values have to be consistent with\n the token identifier used in the L2 operation's price.\n\n NB: if ticket transfers by implicit accounts was supported, these two cases\n could be unified into the application of the [Zk_rollup_publish] operation.\n*)\n\nopen Alpha_context\n\n(** These errors are only to be matched in tests. *)\ntype error +=\n | Zk_rollup_feature_disabled\n (** Emitted when trying to apply a ZK Rollup operation while the ZKRU\n feature flag is not active. *)\n | Zk_rollup_negative_nb_ops\n (** Emitted when originating a ZK Rollup with a negative [nb_ops]. *)\n\n(** [assert_feature_enabled ctxt] asserts that the ZK Rollup feature flag\n is activated.\n\n May fail with:\n {ul\n {li [Zk_rollup_feature_disabled] if the ZKRU feature flag is not\n activated.}\n }\n*)\nval assert_feature_enabled : t -> unit tzresult\n\n(** [originate ~ctxt_before_op ~ctxt ~public_parameters ~transcript\n ~circuits_info ~init_state ~nb_ops]\n applies the origination operation for a ZK rollup.\n See {!Zk_rollup_storage:originate}.\n\n May fail with:\n {ul\n {li [Zk_rollup_feature_disabled] if the ZKRU feature flag is not\n activated.}\n {li [Zk_rollup_negative_nb_ops] if [nb_ops] is negative.}\n }\n*)\nval originate :\n ctxt_before_op:t ->\n ctxt:t ->\n public_parameters:Plonk.public_parameters ->\n circuits_info:[`Public | `Private | `Fee] Zk_rollup.Account.SMap.t ->\n init_state:Zk_rollup.State.t ->\n nb_ops:int ->\n (t\n * Kind.zk_rollup_origination Apply_results.successful_manager_operation_result\n * Script_typed_ir.packed_internal_operation list)\n tzresult\n Lwt.t\n\n(** [publish ~ctxt_before_op ~ctxt ~zk_rollup ~l2_ops]\n applies a publish operation to [zk_rollup] by adding [l2_ops] to its\n pending list.\n\n All L2 operations in [l2_ops] must claim a non-positive [price]\n (see {!Zk_rollup_operation_repr}). In other words, no deposit is\n allowed in this operation, as those must go through an internal\n transaction.\n\n This function will first perform a series of validation checks over\n the L2 operations in [l2_ops]. If all of them are successful, these L2\n operations will be added to [dst_rollup]'s pending list.\n\n May fail with:\n {ul\n {li [Zk_rollup_feature_disabled] if the ZKRU feature flag is not\n activated.\n }\n {li [Zk_rollup.Errors.Deposit_as_external] if the price of an L2\n operation from [ops] is positive.\n }\n {li [Zk_rollup.Errors.Invalid_deposit_amount] if an L2 operation\n declares no ticket but has a non-zero price or if it declares\n a ticket with a price of zero.\n }\n {li [Zk_rollup.Errors.Invalid_deposit_ticket] if an L2 operation's\n ticket identifier (see [Zk_rollup_operation_repr]) is different from\n the hash of its corresponding ticket and [l1_dst].\n }\n {li [Zk_rollup_storage.Zk_rollup_invalid_op_code op_code] if the\n [op_code] of one of the [operations] is greater or equal\n to the number of declared operations for this [zk_rollup].\n }\n }\n*)\nval publish :\n ctxt_before_op:t ->\n ctxt:t ->\n zk_rollup:Zk_rollup.t ->\n l2_ops:(Zk_rollup.Operation.t * Zk_rollup.Ticket.t option) list ->\n (t\n * Kind.zk_rollup_publish Apply_results.successful_manager_operation_result\n * Script_typed_ir.packed_internal_operation list)\n tzresult\n Lwt.t\n\n(** [transaction_to_zk_rollup\n ~ctxt ~parameters_ty ~parameters ~payer ~dst_rollup ~since] applies an\n internal transaction to a ZK [dst_rollup].\n\n Internal transactions are used for deposits into ZK rollups, which can\n be seen as a special case of the publish ZK rollup operation.\n The [parameters] should include a ticket and a ZKRU L2 operation, as\n explained in the {!Zk_rollup_parameters} module's documentation.\n\n This function will first perform a series of validation checks.\n If successful, the L2 operation from the [parameters] will be added\n to [dst_rollup]'s pending list, and [payer] will pay for the\n added storage.\n\n May fail with:\n {ul\n {li [Zk_rollup_feature_disabled] if the ZKRU feature flag is not\n activated.\n }\n {li [Zk_rollup.Errors.Ticket_payload_size_limit_exceeded] if the ticket\n found in the [parameters] exceeds the maximum ticket size.\n }\nu {li [Script_tc_errors.Forbidden_zero_ticket_quantity] if the ticket\n amount is zero.\n }\n {li [Zk_rollup.Errors.Invalid_deposit_amount] if the amount of the ticket\n transferred to the [dst_rollup] is different from the [price]\n (see {!Zk_rollup_operation_repr}) claimed by the L2 operation.\n }\n {li [Zk_rollup.Errors.Invalid_deposit_ticket] if the L2 operation's\n ticket identifier (see {!Zk_rollup_operation_repr}) is different to\n the hash of the transferred ticket and [dst_rollup].\n }\n {li [Zk_rollup_storage.Zk_rollup_invalid_op_code op_code] if the\n [op_code] of the operation from the [parameters] is greater or equal\n to the number of declared operations for this rollup.\n }\n {li [Zk_rollup.Errors.Wrong_deposit_parameters] if the [parameters]\n are not of the expected type. See {!Zk_rollup_parameters}.\n }\n }\n*)\nval transaction_to_zk_rollup :\n ctxt:t ->\n parameters_ty:\n ( ('a Script_typed_ir.ticket, bytes) Script_typed_ir.pair,\n 'b )\n Script_typed_ir.ty ->\n parameters:('a Script_typed_ir.ticket, bytes) Script_typed_ir.pair ->\n dst_rollup:Zk_rollup.t ->\n since:t ->\n (t\n * Kind.transaction Apply_internal_results.successful_internal_operation_result\n * Script_typed_ir.packed_internal_operation list)\n tzresult\n Lwt.t\n\n(** [update ~ctxt_before_op ~ctxt ~zk_rollup ~update ~source_contract]\n applies an [update] to [zk_rollup].\n\n A ZKRU update will verify three sorts of ZK circuits:\n {ul\n {li Public operation circuits, that handle a single L2 operation\n from the pending list.}\n {li Private batch circuits, that handle a batch of private L2\n operations.}\n {li Fee circuit, which credits the ZKRU operator with all the aggregated\n fees from the update.}\n }\n\n The [update] provides some inputs required to perform this verification,\n alongside the proof. See {!Zk_rollup_update_repr}.\n\n If the verification is successful, the [zk_rollup]'s state is updated,\n a prefix of its pending list is dropped and the exits from the ZKRU are\n performed.\n\n May fail with:\n {ul\n {li [Zk_rollup_feature_disabled] if the ZKRU feature flag is not\n activated.\n }\n {li [Zk_rollup.Errors.Pending_bound] if the [update] processes fewer\n public operation than allowed.\n }\n {li [Zk_rollup.Errors.Inconsistent_state_update] if the [update] declares\n a new state of incorrect length.\n }\n {li [Zk_rollup.Errors.Invalid_circuit] if a public operation circuit is\n ran as private.\n }\n {li [Zk_rollup.Errors.Invalid_verification] if the PlonK verification\n fails.\n }\n {li [Zk_rollup.Errors.Invalid_deposit_amount] if an L2 operation without\n a corresponding ticket in the pending list has a non-zero price.\n }\n {li [Zk_rollup_storage.Zk_rollup_pending_list_too_short]\n if the [update] tries to process more public operations than those in\n the pending list.\n }\n }\n*)\nval update :\n ctxt_before_op:t ->\n ctxt:t ->\n zk_rollup:Zk_rollup.t ->\n update:Zk_rollup.Update.t ->\n (t\n * Kind.zk_rollup_update Apply_results.successful_manager_operation_result\n * Script_typed_ir.packed_internal_operation list)\n tzresult\n Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\ntype error += Zk_rollup_feature_disabled | Zk_rollup_negative_nb_ops\n\nlet () =\n let description = \"ZK rollups will be enabled in a future proposal.\" in\n register_error_kind\n `Permanent\n ~id:\"operation.zk_rollup_disabled\"\n ~title:\"ZK rollups are disabled\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.unit\n (function Zk_rollup_feature_disabled -> Some () | _ -> None)\n (fun () -> Zk_rollup_feature_disabled) ;\n let description = \"The value of [nb_ops] should never be negative.\" in\n register_error_kind\n `Permanent\n ~id:\"operation.zk_rollup_negative_nb_ops\"\n ~title:\"ZK rollups negative number of operations\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.unit\n (function Zk_rollup_negative_nb_ops -> Some () | _ -> None)\n (fun () -> Zk_rollup_negative_nb_ops)\n\nlet assert_feature_enabled ctxt =\n error_unless (Constants.zk_rollup_enable ctxt) Zk_rollup_feature_disabled\n\nlet originate ~ctxt_before_op ~ctxt ~public_parameters ~circuits_info\n ~init_state ~nb_ops =\n let open Lwt_result_syntax in\n let*? () = assert_feature_enabled ctxt in\n let*? () = error_when Compare.Int.(nb_ops < 0) Zk_rollup_negative_nb_ops in\n let+ ctxt, originated_zk_rollup, storage_size =\n Zk_rollup.originate\n ctxt\n {\n public_parameters;\n state_length = Array.length init_state;\n circuits_info;\n nb_ops;\n }\n ~init_state\n in\n let consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt in\n let result =\n Apply_results.Zk_rollup_origination_result\n {\n balance_updates = [];\n originated_zk_rollup;\n (* TODO https://gitlab.com/tezos/tezos/-/issues/3544\n Carbonate ZKRU operations *)\n consumed_gas;\n storage_size;\n }\n in\n (ctxt, result, [])\n\n(** [parse_ticket ~ticketer ~contents ~ty ctxt] reconstructs a ticket from\n individual parts submitted as part of a Zk_rollup_publish operation. *)\nlet parse_ticket ~ticketer ~contents ~ty ctxt =\n Script_ir_translator.parse_comparable_ty ctxt (Micheline.root ty)\n >>?= fun (Ex_comparable_ty contents_type, ctxt) ->\n Script_ir_translator.parse_comparable_data\n ctxt\n contents_type\n (Micheline.root contents)\n >>=? fun (contents, ctxt) ->\n return @@ (ctxt, Ticket_token.Ex_token {ticketer; contents_type; contents})\n\nlet publish ~ctxt_before_op ~ctxt ~zk_rollup ~l2_ops =\n let open Lwt_result_syntax in\n let*? () = assert_feature_enabled ctxt in\n let open Zk_rollup.Operation in\n (* Deposits (i.e. L2 operations with a positive price) cannot be published\n through an external operation *)\n let*? () =\n error_unless\n (List.for_all\n (fun (l2_op, _ticket_opt) -> Compare.Z.(l2_op.price.amount <= Z.zero))\n l2_ops)\n Zk_rollup.Errors.Deposit_as_external\n in\n (* Check that for every operation to publish:\n 1. Their price is zero iff they have no ticket representation\n 2. The \"token id\" of its price is the correct ticket hash\n Additionally, for operations with tickets, the hash of the ticket\n with the l1 destination from the operation's header is computed.\n *)\n let* ctxt, l2_ops_with_ticket_hashes =\n List.fold_left_map_es\n (fun ctxt (l2_op, ticket_opt) ->\n match ticket_opt with\n | None ->\n let*? () =\n error_unless\n Compare.Z.(l2_op.price.amount = Z.zero)\n Zk_rollup.Errors.Invalid_deposit_amount\n in\n return (ctxt, (l2_op, None))\n | Some Zk_rollup.Ticket.{ticketer; ty; contents} ->\n let*? () =\n error_when\n Compare.Z.(l2_op.price.amount = Z.zero)\n Zk_rollup.Errors.Invalid_deposit_amount\n in\n let* ctxt, ticket_token =\n parse_ticket ~ticketer ~contents ~ty ctxt\n in\n (* Compute the ticket hash with L1 address to be able\n to perform an exit / return token *)\n let* receiver_ticket_hash, ctxt =\n Ticket_balance_key.of_ex_token\n ctxt\n ~owner:(Contract (Implicit l2_op.l1_dst))\n ticket_token\n in\n (* Compute the ticket with zk rollup as owner, this is the hash\n that is used as token identifier inside the ZKRU (and this\n should be price's identifier in this L2 op) *)\n let* source_ticket_hash, ctxt =\n Ticket_balance_key.of_ex_token\n ctxt\n ~owner:(Zk_rollup zk_rollup)\n ticket_token\n in\n let*? () =\n error_unless\n Ticket_hash.(equal l2_op.price.id source_ticket_hash)\n Zk_rollup.Errors.Invalid_deposit_ticket\n in\n return (ctxt, (l2_op, Some receiver_ticket_hash)))\n ctxt\n l2_ops\n in\n let+ ctxt, paid_storage_size_diff =\n Zk_rollup.add_to_pending ctxt zk_rollup l2_ops_with_ticket_hashes\n in\n (* TODO https://gitlab.com/tezos/tezos/-/issues/3544\n Carbonate ZKRU operations *)\n let consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt in\n let result =\n Apply_results.Zk_rollup_publish_result\n {balance_updates = []; consumed_gas; paid_storage_size_diff}\n in\n (ctxt, result, [])\n\nlet transaction_to_zk_rollup ~ctxt ~parameters_ty ~parameters ~dst_rollup ~since\n =\n let open Lwt_result_syntax in\n let*? () = assert_feature_enabled ctxt in\n let*? {ex_ticket; zkru_operation} =\n Zk_rollup_parameters.get_deposit_parameters parameters_ty parameters\n in\n let* ticket_size, ctxt = Ticket_scanner.ex_ticket_size ctxt ex_ticket in\n let limit = Constants.tx_rollup_max_ticket_payload_size ctxt in\n let*? () =\n error_when\n Saturation_repr.(ticket_size >! limit)\n (Zk_rollup.Errors.Ticket_payload_size_limit_exceeded\n {payload_size = ticket_size; limit})\n in\n let ex_token, ticket_amount =\n Ticket_scanner.ex_token_and_amount_of_ex_ticket ex_ticket\n in\n (* Compute the ticket hash with zk rollup as owner *)\n let* ticket_hash, ctxt =\n Ticket_balance_key.of_ex_token ctxt ~owner:(Zk_rollup dst_rollup) ex_token\n in\n let ticket_amount = Script_int.(to_zint (ticket_amount :> n num)) in\n (* Check that the amount and id of the transferred ticket are what\n the operation's price claims. *)\n let*? () =\n error_unless\n Compare.Z.(ticket_amount = zkru_operation.price.amount)\n Zk_rollup.Errors.Invalid_deposit_amount\n in\n let*? () =\n error_unless\n Ticket_hash.(equal ticket_hash zkru_operation.price.id)\n Zk_rollup.Errors.Invalid_deposit_ticket\n in\n (* Compute the ticket hash with L1 address to be able\n to perform an exit / return token *)\n let* receiver_ticket_hash, ctxt =\n Ticket_balance_key.of_ex_token\n ctxt\n ~owner:(Contract (Implicit zkru_operation.l1_dst))\n ex_token\n in\n (* Add it to the rollup pending list *)\n let+ ctxt, paid_storage_size_diff =\n Zk_rollup.add_to_pending\n ctxt\n Zk_rollup.Operation.(zkru_operation.rollup_id)\n [(zkru_operation, Some receiver_ticket_hash)]\n in\n (* TODO https://gitlab.com/tezos/tezos/-/issues/3544\n Carbonate ZKRU operations *)\n let result =\n Apply_internal_results.(\n ITransaction_result\n (Transaction_to_zk_rollup_result\n {\n balance_updates = [];\n consumed_gas = Gas.consumed ~since ~until:ctxt;\n ticket_hash;\n paid_storage_size_diff;\n }))\n in\n (ctxt, result, [])\n\n(*\n A ZKRU Update will set a new ZKRU state if the proof sent in the payload\n is verified. In order to verify this proof, the protocol needs to\n compute the \"public inputs\" expected by the Plonk circuits that define\n a given ZKRU.\n The proof's public inputs have to be collected by the protocol, as some of\n them will be passed in the operation's payload, but some must be computed\n by the protocol (e.g. the current L2 state).\n These public inputs will be collected as a string map linking\n the circuit identifier to a list of inputs for it (as a circuit might have\n been used several times in a proof).\n As explained in the documentation, circuits in ZKRUs will be grouped into\n three categories: pending (public) operations, private batches and\n fee circuit.\n Each of these expects a different set of public inputs. For this reason,\n the collection of circuit inputs will be collected in three separate steps.\n*)\n\nmodule SMap = Map.Make (String)\n\n(* Helper function to collect inputs *)\nlet insert s x =\n SMap.update s (function None -> Some [x] | Some l -> Some (x :: l))\n\n(* Traverse the list of pending L2 operations paired with their corresponding\n inputs sent in the [Update] computing the full set of inputs for each of\n them.\n Collect the L2 fees of all L2 operations, and the list of boolean flags\n determining whether each L2 operation will trigger an exit.\n*)\nlet collect_pending_ops_inputs ~zk_rollup ~account ~rev_pi_map\n ~pending_ops_and_pis =\n let open Lwt_result_syntax in\n let open Zk_rollup.Update in\n let open Zk_rollup.Account in\n let* rev_pi_map, new_state, fees, rev_exit_validites =\n List.fold_left_es\n (fun (rev_pi_map, old_state, fees, rev_exit_validites)\n ((l2_op, _ticket_hash_opt), (name, (sent_pi : op_pi))) ->\n let new_state = sent_pi.new_state in\n let*? () =\n error_unless\n Compare.Int.(Array.length new_state = account.static.state_length)\n Zk_rollup.Errors.Inconsistent_state_update\n in\n let pi =\n Zk_rollup.Circuit_public_inputs.(\n Pending_op\n {\n old_state;\n new_state;\n fee = sent_pi.fee;\n exit_validity = sent_pi.exit_validity;\n zk_rollup;\n l2_op;\n })\n in\n let rev_pi_map =\n insert\n name\n (Zk_rollup.Circuit_public_inputs.to_scalar_array pi)\n rev_pi_map\n in\n return\n ( rev_pi_map,\n new_state,\n Bls.Primitive.Fr.add fees sent_pi.fee,\n sent_pi.exit_validity :: rev_exit_validites ))\n (rev_pi_map, account.dynamic.state, Bls.Primitive.Fr.zero, [])\n pending_ops_and_pis\n in\n return (rev_pi_map, new_state, fees, List.rev rev_exit_validites)\n\n(* Traverse the partial inputs for the batches of private operations\n that the [update] claims to process, computing the full set of inputs.\n Check that all circuit identifiers used here are allowed to be used for\n private operations and collect the L2 fees. *)\nlet collect_pivate_batch_inputs ~zk_rollup ~account ~rev_pi_map ~update\n ~prev_state ~fees =\n let open Lwt_result_syntax in\n let open Zk_rollup.Update in\n let open Zk_rollup.Account in\n let is_private = function Some `Private -> true | _ -> false in\n List.fold_left_es\n (fun (rev_pi_map, old_state, fees) (name, (sent_pi : private_inner_pi)) ->\n let*? () =\n error_unless\n (is_private\n (Zk_rollup.Account.SMap.find name account.static.circuits_info))\n Zk_rollup.Errors.Invalid_circuit\n in\n let new_state = sent_pi.new_state in\n let*? () =\n error_unless\n Compare.Int.(Array.length new_state = account.static.state_length)\n Zk_rollup.Errors.Inconsistent_state_update\n in\n let pi =\n Zk_rollup.Circuit_public_inputs.(\n Private_batch {old_state; new_state; fees = sent_pi.fees; zk_rollup})\n in\n let rev_pi_map =\n insert\n name\n (Zk_rollup.Circuit_public_inputs.to_scalar_array pi)\n rev_pi_map\n in\n\n return (rev_pi_map, new_state, Bls.Primitive.Fr.add fees sent_pi.fees))\n (rev_pi_map, prev_state, fees)\n update.private_pis\n\nlet collect_fee_inputs ~prev_state ~update ~fees ~rev_pi_map =\n let open Zk_rollup.Update in\n let old_state = prev_state in\n let new_state = update.fee_pi.new_state in\n let pi = Zk_rollup.Circuit_public_inputs.(Fee {old_state; new_state; fees}) in\n let rev_pi_map =\n insert \"fee\" (Zk_rollup.Circuit_public_inputs.to_scalar_array pi) rev_pi_map\n in\n (rev_pi_map, new_state)\n\n(* Collect and validate the public inputs for the verification *)\nlet collect_inputs ~zk_rollup ~account ~rev_pi_map ~pending_ops_and_pis ~update\n =\n let open Lwt_result_syntax in\n (* Collect the inputs for the pending L2 ops *)\n let* rev_pi_map, new_state, fees, exit_validities =\n collect_pending_ops_inputs\n ~zk_rollup\n ~account\n ~rev_pi_map\n ~pending_ops_and_pis\n in\n (* Collect the inputs for private batches of L2 ops *)\n let* rev_pi_map, new_state, fees =\n collect_pivate_batch_inputs\n ~zk_rollup\n ~account\n ~rev_pi_map\n ~update\n ~prev_state:new_state\n ~fees\n in\n (* Collect the inputs for the fee circuit, always identified as \"fee\" *)\n let rev_pi_map, new_state =\n collect_fee_inputs ~prev_state:new_state ~update ~fees ~rev_pi_map\n in\n let pi_map = SMap.map List.rev rev_pi_map in\n return (pi_map, exit_validities, new_state)\n\n(* Perform the exits corresponding to the processed public l2 operations *)\nlet perform_exits ctxt exits =\n let open Lwt_result_syntax in\n List.fold_left_es\n (fun (ctxt, storage_diff) ((op, ticket_hash_opt), exit_validity) ->\n let open Zk_rollup.Operation in\n match ticket_hash_opt with\n | None ->\n let*? () =\n error_unless\n Compare.Z.(Z.zero = op.price.amount)\n Zk_rollup.Errors.Invalid_deposit_amount\n in\n return (ctxt, storage_diff)\n | Some receiver_ticket_hash ->\n if exit_validity then\n let*? amount =\n Option.value_e\n ~error:\n (Error_monad.trace_of_error\n Zk_rollup.Errors.Invalid_deposit_amount)\n (Ticket_amount.of_zint (Z.abs @@ op.price.amount))\n in\n let* ctxt, diff =\n Ticket_transfer.transfer_ticket_with_hashes\n ctxt\n ~src_hash:op.price.id\n ~dst_hash:receiver_ticket_hash\n amount\n in\n return (ctxt, Z.add diff storage_diff)\n else return (ctxt, storage_diff))\n (ctxt, Z.zero)\n exits\n\nlet update ~ctxt_before_op ~ctxt ~zk_rollup ~update =\n let open Lwt_result_syntax in\n let open Zk_rollup.Update in\n let*? () = assert_feature_enabled ctxt in\n let rev_pi_map = SMap.empty in\n let* ctxt, account = Zk_rollup.account ctxt zk_rollup in\n let update_public_length = List.length update.pending_pis in\n let* ctxt, pending_list_length =\n Zk_rollup.get_pending_length ctxt zk_rollup\n in\n let min_pending_to_process =\n Constants.zk_rollup_min_pending_to_process ctxt\n in\n (* The number of pending operations processed by an update must be at least\n [min(pending_list_length, min_pending_to_process)] and at most\n [pending_list_length].*)\n let*? () =\n error_when\n Compare.Int.(\n update_public_length < pending_list_length\n && update_public_length < min_pending_to_process)\n Zk_rollup.Errors.Pending_bound\n in\n let* ctxt, pending_ops =\n Zk_rollup.get_prefix ctxt zk_rollup update_public_length\n in\n (* It's safe to use [combine_drop], as at this point both lists will have the\n same length. *)\n let pending_ops_and_pis = List.combine_drop pending_ops update.pending_pis in\n (* Collect the inputs for the verification *)\n let* pi_map, exit_validities, new_state =\n collect_inputs ~zk_rollup ~account ~rev_pi_map ~pending_ops_and_pis ~update\n in\n (* Run the verification of the Plonk proof *)\n let verified =\n Plonk.verify\n account.static.public_parameters\n (SMap.bindings pi_map)\n update.proof\n in\n let*? () = error_unless verified Zk_rollup.Errors.Invalid_verification in\n (* Update the ZKRU storage with the new state and dropping the processed\n public L2 operations from the pending list *)\n let* ctxt =\n Zk_rollup.update\n ctxt\n zk_rollup\n ~pending_to_drop:update_public_length\n ~new_account:\n {account with dynamic = {account.dynamic with state = new_state}}\n in\n (* Perform exits of processed public L2 operations *)\n let exits = List.combine_drop pending_ops exit_validities in\n let* ctxt, exits_paid_storage_size_diff = perform_exits ctxt exits in\n\n (* TODO https://gitlab.com/tezos/tezos/-/issues/3544\n Carbonate ZKRU operations *)\n let consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt in\n let result =\n Apply_results.Zk_rollup_update_result\n {\n balance_updates = [];\n consumed_gas;\n paid_storage_size_diff = exits_paid_storage_size_diff;\n }\n in\n return (ctxt, result, [])\n" ;
} ;
{ name = "Baking" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\ntype error +=\n | (* `Permanent *)\n Insufficient_endorsing_power of {\n endorsing_power : int;\n consensus_threshold : int;\n }\n\ntype ordered_slots = private {\n delegate : Signature.public_key_hash;\n consensus_key : Signature.public_key_hash;\n slots : Slot.t list;\n}\n\n(** For a given level computes who has the right to include an endorsement in\n the next block.\n\n @return map from delegates with such rights to their endorsing slots, in\n increasing order.\n\n This function is only used by the 'validators' RPC. *)\nval endorsing_rights :\n context ->\n Level.t ->\n (context * ordered_slots Signature.Public_key_hash.Map.t) tzresult Lwt.t\n\n(** Computes endorsing rights for a given level.\n\n @return map from allocated first slots to their owner's public key, public key\n hash, and endorsing power. *)\nval endorsing_rights_by_first_slot :\n context ->\n Level.t ->\n (context * (Consensus_key.pk * int) Slot.Map.t) tzresult Lwt.t\n\n(** Computes the bonus baking reward depending on the endorsing power. *)\nval bonus_baking_reward : context -> endorsing_power:int -> Tez.t tzresult\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\ntype error +=\n | (* `Permanent *)\n Insufficient_endorsing_power of {\n endorsing_power : int;\n consensus_threshold : int;\n }\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"baking.insufficient_endorsing_power\"\n ~title:\"Insufficient endorsing power\"\n ~description:\n \"The endorsing power is insufficient to satisfy the consensus threshold.\"\n ~pp:(fun ppf (endorsing_power, consensus_threshold) ->\n Format.fprintf\n ppf\n \"The endorsing power (%d) is insufficient to satisfy the consensus \\\n threshold (%d).\"\n endorsing_power\n consensus_threshold)\n Data_encoding.(\n obj2 (req \"endorsing_power\" int31) (req \"consensus_threshold\" int31))\n (function\n | Insufficient_endorsing_power {endorsing_power; consensus_threshold} ->\n Some (endorsing_power, consensus_threshold)\n | _ -> None)\n (fun (endorsing_power, consensus_threshold) ->\n Insufficient_endorsing_power {endorsing_power; consensus_threshold})\n\nlet bonus_baking_reward ctxt ~endorsing_power =\n let consensus_threshold = Constants.consensus_threshold ctxt in\n let baking_reward_bonus_per_slot =\n Constants.baking_reward_bonus_per_slot ctxt\n in\n let extra_endorsing_power = endorsing_power - consensus_threshold in\n error_when\n Compare.Int.(extra_endorsing_power < 0)\n (Insufficient_endorsing_power {endorsing_power; consensus_threshold})\n >>? fun () ->\n Tez.(baking_reward_bonus_per_slot *? Int64.of_int extra_endorsing_power)\n\ntype ordered_slots = {\n delegate : Signature.public_key_hash;\n consensus_key : Signature.public_key_hash;\n slots : Slot.t list;\n}\n\n(* Slots returned by this function are assumed by consumers to be in increasing\n order, hence the use of [Slot.Range.rev_fold_es]. *)\nlet endorsing_rights (ctxt : t) level =\n let consensus_committee_size = Constants.consensus_committee_size ctxt in\n Slot.Range.create ~min:0 ~count:consensus_committee_size >>?= fun slots ->\n Slot.Range.rev_fold_es\n (fun (ctxt, map) slot ->\n Stake_distribution.slot_owner ctxt level slot\n >>=? fun (ctxt, consensus_pk) ->\n let map =\n Signature.Public_key_hash.Map.update\n consensus_pk.delegate\n (function\n | None ->\n Some\n {\n delegate = consensus_pk.delegate;\n consensus_key = consensus_pk.consensus_pkh;\n slots = [slot];\n }\n | Some slots -> Some {slots with slots = slot :: slots.slots})\n map\n in\n return (ctxt, map))\n (ctxt, Signature.Public_key_hash.Map.empty)\n slots\n\nlet endorsing_rights_by_first_slot ctxt level =\n Slot.Range.create ~min:0 ~count:(Constants.consensus_committee_size ctxt)\n >>?= fun slots ->\n Slot.Range.fold_es\n (fun (ctxt, (delegates_map, slots_map)) slot ->\n Stake_distribution.slot_owner ctxt level slot\n >|=? fun (ctxt, consensus_pk) ->\n let initial_slot, delegates_map =\n match\n Signature.Public_key_hash.Map.find consensus_pk.delegate delegates_map\n with\n | None ->\n ( slot,\n Signature.Public_key_hash.Map.add\n consensus_pk.delegate\n slot\n delegates_map )\n | Some initial_slot -> (initial_slot, delegates_map)\n in\n (* [slots_map]'keys are the minimal slots of delegates because\n we fold on slots in increasing order *)\n let slots_map =\n Slot.Map.update\n initial_slot\n (function\n | None -> Some (consensus_pk, 1)\n | Some (consensus_pk, count) -> Some (consensus_pk, count + 1))\n slots_map\n in\n (ctxt, (delegates_map, slots_map)))\n (ctxt, (Signature.Public_key_hash.Map.empty, Slot.Map.empty))\n slots\n >>=? fun (ctxt, (_, slots_map)) -> return (ctxt, slots_map)\n" ;
} ;
{ name = "Validate_errors" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\n(** type used for conflicting operation. *)\ntype operation_conflict =\n | Operation_conflict of {\n existing : Operation_hash.t;\n new_operation : Operation_hash.t;\n }\n\n(** Errors that may arise while validating a consensus operation. *)\nmodule Consensus : sig\n type consensus_operation_kind =\n | Preendorsement\n | Endorsement\n | Grandparent_endorsement\n | Dal_attestation\n\n (** Errors for preendorsements and endorsements. *)\n type error +=\n | Zero_frozen_deposits of Signature.Public_key_hash.t\n | Consensus_operation_not_allowed\n | Consensus_operation_for_old_level of {\n kind : consensus_operation_kind;\n expected : Raw_level.t;\n provided : Raw_level.t;\n }\n | Consensus_operation_for_future_level of {\n kind : consensus_operation_kind;\n expected : Raw_level.t;\n provided : Raw_level.t;\n }\n | Consensus_operation_for_old_round of {\n kind : consensus_operation_kind;\n expected : Round.t;\n provided : Round.t;\n }\n | Consensus_operation_for_future_round of {\n kind : consensus_operation_kind;\n expected : Round.t;\n provided : Round.t;\n }\n | Wrong_consensus_operation_branch of {\n kind : consensus_operation_kind;\n expected : Block_hash.t;\n provided : Block_hash.t;\n }\n | Wrong_payload_hash_for_consensus_operation of {\n kind : consensus_operation_kind;\n expected : Block_payload_hash.t;\n provided : Block_payload_hash.t;\n }\n | Unexpected_preendorsement_in_block\n | Unexpected_endorsement_in_block\n | Preendorsement_round_too_high of {\n block_round : Round.t;\n provided : Round.t;\n }\n | Wrong_slot_used_for_consensus_operation of {\n kind : consensus_operation_kind;\n }\n | Conflicting_consensus_operation of {\n kind : consensus_operation_kind;\n conflict : operation_conflict;\n }\nend\n\n(** Errors that may arise while validating a voting operation. *)\nmodule Voting : sig\n type error +=\n | (* Shared voting errors *)\n Wrong_voting_period_index of {\n expected : int32;\n provided : int32;\n }\n | Wrong_voting_period_kind of {\n current : Voting_period.kind;\n expected : Voting_period.kind list;\n }\n | Source_not_in_vote_listings\n | (* Proposals errors *)\n Empty_proposals\n | Proposals_contain_duplicate of {proposal : Protocol_hash.t}\n | Already_proposed of {proposal : Protocol_hash.t}\n | Too_many_proposals of {previous_count : int; operation_count : int}\n | Conflicting_proposals of operation_conflict\n | Testnet_dictator_multiple_proposals\n | Proposals_from_unregistered_delegate of Signature.Public_key_hash.t\n | (* Ballot errors *)\n Ballot_for_wrong_proposal of {\n current : Protocol_hash.t;\n submitted : Protocol_hash.t;\n }\n | Already_submitted_a_ballot\n | Ballot_from_unregistered_delegate of Signature.Public_key_hash.t\n | Conflicting_ballot of operation_conflict\nend\n\n(** Errors that may arise while validating an anonymous operation. *)\nmodule Anonymous : sig\n type denunciation_kind = Preendorsement | Endorsement | Block\n\n type error +=\n | Invalid_activation of {pkh : Ed25519.Public_key_hash.t}\n | Conflicting_activation of {\n edpkh : Ed25519.Public_key_hash.t;\n conflict : operation_conflict;\n }\n | Invalid_denunciation of denunciation_kind\n | Invalid_double_baking_evidence of {\n hash1 : Block_hash.t;\n level1 : Raw_level.t;\n round1 : Round.t;\n hash2 : Block_hash.t;\n level2 : Raw_level.t;\n round2 : Round.t;\n }\n | Inconsistent_denunciation of {\n kind : denunciation_kind;\n delegate1 : Signature.Public_key_hash.t;\n delegate2 : Signature.Public_key_hash.t;\n }\n | Already_denounced of {\n kind : denunciation_kind;\n delegate : Signature.Public_key_hash.t;\n level : Level.t;\n }\n | Conflicting_denunciation of {\n kind : denunciation_kind;\n conflict : operation_conflict;\n }\n | Too_early_denunciation of {\n kind : denunciation_kind;\n level : Raw_level.t;\n current : Raw_level.t;\n }\n | Outdated_denunciation of {\n kind : denunciation_kind;\n level : Raw_level.t;\n last_cycle : Cycle.t;\n }\n | Conflicting_nonce_revelation of operation_conflict\n | Conflicting_vdf_revelation of operation_conflict\n | Drain_delegate_on_unregistered_delegate of Signature.Public_key_hash.t\n | Invalid_drain_delegate_inactive_key of {\n delegate : Signature.Public_key_hash.t;\n consensus_key : Signature.Public_key_hash.t;\n active_consensus_key : Signature.Public_key_hash.t;\n }\n | Invalid_drain_delegate_no_consensus_key of Signature.Public_key_hash.t\n | Invalid_drain_delegate_noop of Signature.Public_key_hash.t\n | Invalid_drain_delegate_insufficient_funds_for_burn_or_fees of {\n delegate : Signature.Public_key_hash.t;\n destination : Signature.Public_key_hash.t;\n min_amount : Tez.t;\n }\n | Conflicting_drain_delegate of {\n delegate : Signature.Public_key_hash.t;\n conflict : operation_conflict;\n }\nend\n\n(** Errors that may arise while validating a manager operation. *)\nmodule Manager : sig\n type error +=\n | Manager_restriction of {\n source : Signature.Public_key_hash.t;\n conflict : operation_conflict;\n }\n | Inconsistent_sources\n | Inconsistent_counters\n | Incorrect_reveal_position\n | Insufficient_gas_for_manager\n | Gas_quota_exceeded_init_deserialize\n | Tx_rollup_feature_disabled\n | Sc_rollup_feature_disabled\n | Sc_rollup_arith_pvm_disabled\n | Zk_rollup_feature_disabled\nend\n\ntype error += Failing_noop_error\n\nmodule Block : sig\n type error +=\n | Not_enough_endorsements of {required : int; provided : int}\n | Inconsistent_validation_passes_in_block of {\n expected : int;\n provided : int;\n }\nend\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\ntype operation_conflict =\n | Operation_conflict of {\n existing : Operation_hash.t;\n new_operation : Operation_hash.t;\n }\n\nlet operation_conflict_encoding =\n let open Data_encoding in\n def\n \"operation_conflict\"\n ~title:\"Conflict error\"\n ~description:\"Conflict between two operations\"\n @@ conv\n (function\n | Operation_conflict {existing; new_operation} ->\n (existing, new_operation))\n (fun (existing, new_operation) ->\n Operation_conflict {existing; new_operation})\n (obj2\n (req \"existing\" Operation_hash.encoding)\n (req \"new_operation\" Operation_hash.encoding))\n\nmodule Consensus = struct\n type error += Zero_frozen_deposits of Signature.Public_key_hash.t\n\n let () =\n register_error_kind\n `Permanent\n ~id:\"validate.zero_frozen_deposits\"\n ~title:\"Zero frozen deposits\"\n ~description:\"The delegate has zero frozen deposits.\"\n ~pp:(fun ppf delegate ->\n Format.fprintf\n ppf\n \"Delegate %a has zero frozen deposits; it is not allowed to \\\n bake/preendorse/endorse.\"\n Signature.Public_key_hash.pp\n delegate)\n Data_encoding.(obj1 (req \"delegate\" Signature.Public_key_hash.encoding))\n (function Zero_frozen_deposits delegate -> Some delegate | _ -> None)\n (fun delegate -> Zero_frozen_deposits delegate)\n\n (** This type is only used in consensus operation errors to make\n them more informative. *)\n type consensus_operation_kind =\n | Preendorsement\n | Endorsement\n | Grandparent_endorsement\n | Dal_attestation\n\n let consensus_operation_kind_encoding =\n Data_encoding.string_enum\n [\n (\"Preendorsement\", Preendorsement);\n (\"Endorsement\", Endorsement);\n (\"Grandparent_endorsement\", Grandparent_endorsement);\n (\"Dal_attestation\", Dal_attestation);\n ]\n\n let consensus_operation_kind_pp fmt = function\n | Preendorsement -> Format.fprintf fmt \"Preendorsement\"\n | Endorsement -> Format.fprintf fmt \"Endorsement\"\n | Grandparent_endorsement -> Format.fprintf fmt \"Grandparent endorsement\"\n | Dal_attestation -> Format.fprintf fmt \"Dal_attestation\"\n\n (** Errors for preendorsements and endorsements. *)\n type error +=\n | Consensus_operation_for_old_level of {\n kind : consensus_operation_kind;\n expected : Raw_level.t;\n provided : Raw_level.t;\n }\n | Consensus_operation_for_future_level of {\n kind : consensus_operation_kind;\n expected : Raw_level.t;\n provided : Raw_level.t;\n }\n | Consensus_operation_for_old_round of {\n kind : consensus_operation_kind;\n expected : Round.t;\n provided : Round.t;\n }\n | Consensus_operation_for_future_round of {\n kind : consensus_operation_kind;\n expected : Round.t;\n provided : Round.t;\n }\n | Wrong_consensus_operation_branch of {\n kind : consensus_operation_kind;\n expected : Block_hash.t;\n provided : Block_hash.t;\n }\n | Wrong_payload_hash_for_consensus_operation of {\n kind : consensus_operation_kind;\n expected : Block_payload_hash.t;\n provided : Block_payload_hash.t;\n }\n | Unexpected_preendorsement_in_block\n | Unexpected_endorsement_in_block\n | Preendorsement_round_too_high of {\n block_round : Round.t;\n provided : Round.t;\n }\n | Wrong_slot_used_for_consensus_operation of {\n kind : consensus_operation_kind;\n }\n | Conflicting_consensus_operation of {\n kind : consensus_operation_kind;\n conflict : operation_conflict;\n }\n | Consensus_operation_not_allowed\n\n let () =\n register_error_kind\n `Outdated\n ~id:\"validate.consensus_operation_for_old_level\"\n ~title:\"Consensus operation for old level\"\n ~description:\"Consensus operation for old level.\"\n ~pp:(fun ppf (kind, expected, provided) ->\n Format.fprintf\n ppf\n \"%a for old level (expected: %a, provided: %a).\"\n consensus_operation_kind_pp\n kind\n Raw_level.pp\n expected\n Raw_level.pp\n provided)\n Data_encoding.(\n obj3\n (req \"kind\" consensus_operation_kind_encoding)\n (req \"expected\" Raw_level.encoding)\n (req \"provided\" Raw_level.encoding))\n (function\n | Consensus_operation_for_old_level {kind; expected; provided} ->\n Some (kind, expected, provided)\n | _ -> None)\n (fun (kind, expected, provided) ->\n Consensus_operation_for_old_level {kind; expected; provided}) ;\n register_error_kind\n `Temporary\n ~id:\"validate.consensus_operation_for_future_level\"\n ~title:\"Consensus operation for future level\"\n ~description:\"Consensus operation for future level.\"\n ~pp:(fun ppf (kind, expected, provided) ->\n Format.fprintf\n ppf\n \"%a for future level (expected: %a, provided: %a).\"\n consensus_operation_kind_pp\n kind\n Raw_level.pp\n expected\n Raw_level.pp\n provided)\n Data_encoding.(\n obj3\n (req \"kind\" consensus_operation_kind_encoding)\n (req \"expected\" Raw_level.encoding)\n (req \"provided\" Raw_level.encoding))\n (function\n | Consensus_operation_for_future_level {kind; expected; provided} ->\n Some (kind, expected, provided)\n | _ -> None)\n (fun (kind, expected, provided) ->\n Consensus_operation_for_future_level {kind; expected; provided}) ;\n register_error_kind\n `Branch\n ~id:\"validate.consensus_operation_for_old_round\"\n ~title:\"Consensus operation for old round\"\n ~description:\"Consensus operation for old round.\"\n ~pp:(fun ppf (kind, expected, provided) ->\n Format.fprintf\n ppf\n \"%a for old round (expected_min: %a, provided: %a).\"\n consensus_operation_kind_pp\n kind\n Round.pp\n expected\n Round.pp\n provided)\n Data_encoding.(\n obj3\n (req \"kind\" consensus_operation_kind_encoding)\n (req \"expected_min\" Round.encoding)\n (req \"provided\" Round.encoding))\n (function\n | Consensus_operation_for_old_round {kind; expected; provided} ->\n Some (kind, expected, provided)\n | _ -> None)\n (fun (kind, expected, provided) ->\n Consensus_operation_for_old_round {kind; expected; provided}) ;\n register_error_kind\n `Temporary\n ~id:\"validate.consensus_operation_for_future_round\"\n ~title:\"Consensus operation for future round\"\n ~description:\"Consensus operation for future round.\"\n ~pp:(fun ppf (kind, expected, provided) ->\n Format.fprintf\n ppf\n \"%a for future round (expected: %a, provided: %a).\"\n consensus_operation_kind_pp\n kind\n Round.pp\n expected\n Round.pp\n provided)\n Data_encoding.(\n obj3\n (req \"kind\" consensus_operation_kind_encoding)\n (req \"expected_max\" Round.encoding)\n (req \"provided\" Round.encoding))\n (function\n | Consensus_operation_for_future_round {kind; expected; provided} ->\n Some (kind, expected, provided)\n | _ -> None)\n (fun (kind, expected, provided) ->\n Consensus_operation_for_future_round {kind; expected; provided}) ;\n register_error_kind\n `Temporary\n ~id:\"validate.wrong_consensus_operation_branch\"\n ~title:\"Wrong consensus operation branch\"\n ~description:\n \"Trying to include an endorsement or preendorsement which points to \\\n the wrong block. It should be the predecessor for preendorsements and \\\n the grandfather for endorsements.\"\n ~pp:(fun ppf (kind, expected, provided) ->\n Format.fprintf\n ppf\n \"%a with wrong branch (expected: %a, provided: %a).\"\n consensus_operation_kind_pp\n kind\n Block_hash.pp\n expected\n Block_hash.pp\n provided)\n Data_encoding.(\n obj3\n (req \"kind\" consensus_operation_kind_encoding)\n (req \"expected\" Block_hash.encoding)\n (req \"provided\" Block_hash.encoding))\n (function\n | Wrong_consensus_operation_branch {kind; expected; provided} ->\n Some (kind, expected, provided)\n | _ -> None)\n (fun (kind, expected, provided) ->\n Wrong_consensus_operation_branch {kind; expected; provided}) ;\n register_error_kind\n (* Note: in Mempool mode this used to be\n Consensus_operation_on_competing_proposal (which was\n [`Branch] so we kept this classification). *)\n `Branch\n ~id:\"validate.wrong_payload_hash_for_consensus_operation\"\n ~title:\"Wrong payload hash for consensus operation\"\n ~description:\"Wrong payload hash for consensus operation.\"\n ~pp:(fun ppf (kind, expected, provided) ->\n Format.fprintf\n ppf\n \"%a with wrong payload hash (expected: %a, provided: %a).\"\n consensus_operation_kind_pp\n kind\n Block_payload_hash.pp_short\n expected\n Block_payload_hash.pp_short\n provided)\n Data_encoding.(\n obj3\n (req \"kind\" consensus_operation_kind_encoding)\n (req \"expected\" Block_payload_hash.encoding)\n (req \"provided\" Block_payload_hash.encoding))\n (function\n | Wrong_payload_hash_for_consensus_operation {kind; expected; provided}\n ->\n Some (kind, expected, provided)\n | _ -> None)\n (fun (kind, expected, provided) ->\n Wrong_payload_hash_for_consensus_operation {kind; expected; provided}) ;\n register_error_kind\n `Permanent\n ~id:\"validate.unexpected_preendorsement_in_block\"\n ~title:\"Unexpected preendorsement in block\"\n ~description:\"Unexpected preendorsement in block.\"\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"Unexpected preendorsement in block.\")\n Data_encoding.empty\n (function Unexpected_preendorsement_in_block -> Some () | _ -> None)\n (fun () -> Unexpected_preendorsement_in_block) ;\n register_error_kind\n `Permanent\n ~id:\"validate.unexpected_endorsement_in_block\"\n ~title:\"Unexpected endorsement in block\"\n ~description:\"Unexpected endorsement in block.\"\n ~pp:(fun ppf () -> Format.fprintf ppf \"Unexpected endorsement in block.\")\n Data_encoding.empty\n (function Unexpected_endorsement_in_block -> Some () | _ -> None)\n (fun () -> Unexpected_endorsement_in_block) ;\n register_error_kind\n `Permanent\n ~id:\"validate.preendorsement_round_too_high\"\n ~title:\"Preendorsement round too high\"\n ~description:\"Preendorsement round too high.\"\n ~pp:(fun ppf (block_round, provided) ->\n Format.fprintf\n ppf\n \"Preendorsement round too high (block_round: %a, provided: %a).\"\n Round.pp\n block_round\n Round.pp\n provided)\n Data_encoding.(\n obj2 (req \"block_round\" Round.encoding) (req \"provided\" Round.encoding))\n (function\n | Preendorsement_round_too_high {block_round; provided} ->\n Some (block_round, provided)\n | _ -> None)\n (fun (block_round, provided) ->\n Preendorsement_round_too_high {block_round; provided}) ;\n register_error_kind\n `Permanent\n ~id:\"validate.wrong_slot_for_consensus_operation\"\n ~title:\"Wrong slot for consensus operation\"\n ~description:\"Wrong slot used for a preendorsement or endorsement.\"\n ~pp:(fun ppf kind ->\n Format.fprintf\n ppf\n \"Wrong slot used for a %a.\"\n consensus_operation_kind_pp\n kind)\n Data_encoding.(obj1 (req \"kind\" consensus_operation_kind_encoding))\n (function\n | Wrong_slot_used_for_consensus_operation {kind} -> Some kind\n | _ -> None)\n (fun kind -> Wrong_slot_used_for_consensus_operation {kind}) ;\n register_error_kind\n `Branch\n ~id:\"validate.double_inclusion_of_consensus_operation\"\n ~title:\"Double inclusion of consensus operation\"\n ~description:\"Double inclusion of consensus operation.\"\n ~pp:(fun ppf (kind, Operation_conflict {existing; new_operation}) ->\n Format.fprintf\n ppf\n \"%a operation %a conflicts with existing %a\"\n consensus_operation_kind_pp\n kind\n Operation_hash.pp\n new_operation\n Operation_hash.pp\n existing)\n Data_encoding.(\n obj2\n (req \"kind\" consensus_operation_kind_encoding)\n (req \"conflict\" operation_conflict_encoding))\n (function\n | Conflicting_consensus_operation {kind; conflict} ->\n Some (kind, conflict)\n | _ -> None)\n (fun (kind, conflict) -> Conflicting_consensus_operation {kind; conflict}) ;\n register_error_kind\n `Branch\n ~id:\"validate.consensus_operation_not_allowed\"\n ~title:\"Consensus operation not allowed\"\n ~description:\"Consensus operation not allowed.\"\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"Validation of consensus operation if forbidden \")\n Data_encoding.empty\n (function Consensus_operation_not_allowed -> Some () | _ -> None)\n (fun () -> Consensus_operation_not_allowed)\nend\n\nmodule Voting = struct\n type error +=\n | (* Shared voting errors *)\n Wrong_voting_period_index of {\n expected : int32;\n provided : int32;\n }\n | Wrong_voting_period_kind of {\n current : Voting_period.kind;\n expected : Voting_period.kind list;\n }\n | Source_not_in_vote_listings\n | (* Proposals errors *)\n Empty_proposals\n | Proposals_contain_duplicate of {proposal : Protocol_hash.t}\n | Already_proposed of {proposal : Protocol_hash.t}\n | Too_many_proposals of {previous_count : int; operation_count : int}\n | Conflicting_proposals of operation_conflict\n | Testnet_dictator_multiple_proposals\n | Proposals_from_unregistered_delegate of Signature.Public_key_hash.t\n | (* Ballot errors *)\n Ballot_for_wrong_proposal of {\n current : Protocol_hash.t;\n submitted : Protocol_hash.t;\n }\n | Already_submitted_a_ballot\n | Ballot_from_unregistered_delegate of Signature.Public_key_hash.t\n | Conflicting_ballot of operation_conflict\n\n let () =\n (* Shared voting errors *)\n register_error_kind\n `Temporary\n ~id:\"validate.operation.wrong_voting_period_index\"\n ~title:\"Wrong voting period index\"\n ~description:\n \"The voting operation contains a voting period index different from \\\n the current one.\"\n ~pp:(fun ppf (expected, provided) ->\n Format.fprintf\n ppf\n \"The voting operation is meant for voting period %ld, whereas the \\\n current period is %ld.\"\n provided\n expected)\n Data_encoding.(\n obj2 (req \"current_index\" int32) (req \"provided_index\" int32))\n (function\n | Wrong_voting_period_index {expected; provided} ->\n Some (expected, provided)\n | _ -> None)\n (fun (expected, provided) ->\n Wrong_voting_period_index {expected; provided}) ;\n register_error_kind\n `Temporary\n ~id:\"validate.operation.wrong_voting_period_kind\"\n ~title:\"Wrong voting period kind\"\n ~description:\n \"The voting operation is incompatible the current voting period kind.\"\n ~pp:(fun ppf (current, expected) ->\n Format.fprintf\n ppf\n \"The voting operation is only valid during a %a voting period, but \\\n we are currently in a %a period.\"\n (Format.pp_print_list\n ~pp_sep:(fun fmt () -> Format.fprintf fmt \" or \")\n Voting_period.pp_kind)\n expected\n Voting_period.pp_kind\n current)\n Data_encoding.(\n obj2\n (req \"current\" Voting_period.kind_encoding)\n (req \"expected\" (list Voting_period.kind_encoding)))\n (function\n | Wrong_voting_period_kind {current; expected} ->\n Some (current, expected)\n | _ -> None)\n (fun (current, expected) -> Wrong_voting_period_kind {current; expected}) ;\n let description = \"The delegate is not in the vote listings.\" in\n register_error_kind\n `Temporary\n ~id:\"validate.operation.source_not_in_vote_listings\"\n ~title:\"Source not in vote listings\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Source_not_in_vote_listings -> Some () | _ -> None)\n (fun () -> Source_not_in_vote_listings) ;\n\n (* Proposals errors *)\n let description = \"Proposal list cannot be empty.\" in\n register_error_kind\n `Permanent\n ~id:\"validate.operation.empty_proposals\"\n ~title:\"Empty proposals\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Empty_proposals -> Some () | _ -> None)\n (fun () -> Empty_proposals) ;\n register_error_kind\n `Permanent\n ~id:\"validate.operation.proposals_contain_duplicate\"\n ~title:\"Proposals contain duplicate\"\n ~description:\"The list of proposals contains a duplicate element.\"\n ~pp:(fun ppf proposal ->\n Format.fprintf\n ppf\n \"The list of proposals contains multiple occurrences of the proposal \\\n %a.\"\n Protocol_hash.pp\n proposal)\n Data_encoding.(obj1 (req \"proposal\" Protocol_hash.encoding))\n (function\n | Proposals_contain_duplicate {proposal} -> Some proposal | _ -> None)\n (fun proposal -> Proposals_contain_duplicate {proposal}) ;\n register_error_kind\n `Branch\n ~id:\"validate.operation.already_proposed\"\n ~title:\"Already proposed\"\n ~description:\n \"The delegate has already submitted one of the operation's proposals.\"\n ~pp:(fun ppf proposal ->\n Format.fprintf\n ppf\n \"The delegate has already submitted the proposal %a.\"\n Protocol_hash.pp\n proposal)\n Data_encoding.(obj1 (req \"proposal\" Protocol_hash.encoding))\n (function Already_proposed {proposal} -> Some proposal | _ -> None)\n (fun proposal -> Already_proposed {proposal}) ;\n register_error_kind\n `Temporary\n ~id:\"validate.operation.conflict_too_many_proposals\"\n ~title:\"Conflict too many proposals\"\n ~description:\n \"The delegate exceeded the maximum number of allowed proposals due to, \\\n among others, previous Proposals operations in the current \\\n block/mempool.\"\n ~pp:(fun ppf (previous_count, operation_count) ->\n Format.fprintf\n ppf\n \"The delegate cannot submit too many protocol proposals: it \\\n currently voted for %d and is trying to vote for %d more.\"\n previous_count\n operation_count)\n Data_encoding.(\n obj2 (req \"previous_count\" int8) (req \"operation_count\" int31))\n (function\n | Too_many_proposals {previous_count; operation_count} ->\n Some (previous_count, operation_count)\n | _ -> None)\n (fun (previous_count, operation_count) ->\n Too_many_proposals {previous_count; operation_count}) ;\n register_error_kind\n `Temporary\n ~id:\"validate.operation.conflicting_proposals\"\n ~title:\"Conflicting proposals\"\n ~description:\n \"The current block/mempool already contains a testnest dictator \\\n proposals operation, so it cannot have any other voting operation.\"\n ~pp:(fun ppf (Operation_conflict {existing; _}) ->\n Format.fprintf\n ppf\n \"The current block/mempool already contains a conflicting operation \\\n %a.\"\n Operation_hash.pp\n existing)\n Data_encoding.(obj1 (req \"conflict\" operation_conflict_encoding))\n (function Conflicting_proposals conflict -> Some conflict | _ -> None)\n (fun conflict -> Conflicting_proposals conflict) ;\n let description =\n \"A testnet dictator cannot submit more than one proposal at a time.\"\n in\n register_error_kind\n `Permanent\n ~id:\"validate.operation.testnet_dictator_multiple_proposals\"\n ~title:\"Testnet dictator multiple proposals\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Testnet_dictator_multiple_proposals -> Some () | _ -> None)\n (fun () -> Testnet_dictator_multiple_proposals) ;\n register_error_kind\n `Permanent\n ~id:\"operation.proposals_from_unregistered_delegate\"\n ~title:\"Proposals from an unregistered delegate\"\n ~description:\"Cannot submit proposals with an unregistered delegate.\"\n ~pp:(fun ppf c ->\n Format.fprintf\n ppf\n \"Cannot submit proposals with public key hash %a (unregistered \\\n delegate).\"\n Signature.Public_key_hash.pp\n c)\n Data_encoding.(obj1 (req \"delegate\" Signature.Public_key_hash.encoding))\n (function Proposals_from_unregistered_delegate c -> Some c | _ -> None)\n (fun c -> Proposals_from_unregistered_delegate c) ;\n\n (* Ballot errors *)\n register_error_kind\n `Branch\n ~id:\"validate.operation.ballot_for_wrong_proposal\"\n ~title:\"Ballot for wrong proposal\"\n ~description:\"Ballot provided for a proposal that is not the current one.\"\n ~pp:(fun ppf (current, submitted) ->\n Format.fprintf\n ppf\n \"Ballot provided for proposal %a whereas the current proposal is %a.\"\n Protocol_hash.pp\n submitted\n Protocol_hash.pp\n current)\n Data_encoding.(\n obj2\n (req \"current_proposal\" Protocol_hash.encoding)\n (req \"ballot_proposal\" Protocol_hash.encoding))\n (function\n | Ballot_for_wrong_proposal {current; submitted} ->\n Some (current, submitted)\n | _ -> None)\n (fun (current, submitted) ->\n Ballot_for_wrong_proposal {current; submitted}) ;\n let description =\n \"The delegate has already submitted a ballot for the current voting \\\n period.\"\n in\n register_error_kind\n `Branch\n ~id:\"validate.operation.already_submitted_a_ballot\"\n ~title:\"Already submitted a ballot\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Already_submitted_a_ballot -> Some () | _ -> None)\n (fun () -> Already_submitted_a_ballot) ;\n register_error_kind\n `Permanent\n ~id:\"operation.ballot_from_unregistered_delegate\"\n ~title:\"Ballot from an unregistered delegate\"\n ~description:\"Cannot cast a ballot for an unregistered delegate.\"\n ~pp:(fun ppf c ->\n Format.fprintf\n ppf\n \"Cannot cast a ballot for public key hash %a (unregistered delegate).\"\n Signature.Public_key_hash.pp\n c)\n Data_encoding.(obj1 (req \"delegate\" Signature.Public_key_hash.encoding))\n (function Ballot_from_unregistered_delegate c -> Some c | _ -> None)\n (fun c -> Ballot_from_unregistered_delegate c) ;\n register_error_kind\n `Temporary\n ~id:\"validate.operation.conflicting_ballot\"\n ~title:\"Conflicting ballot\"\n ~description:\n \"The delegate has already submitted a ballot in a previously validated \\\n operation of the current block or mempool.\"\n ~pp:(fun ppf (Operation_conflict {existing; _}) ->\n Format.fprintf\n ppf\n \"The delegate has already submitted a ballot in the previously \\\n validated operation %a of the current block or mempool.\"\n Operation_hash.pp\n existing)\n Data_encoding.(obj1 (req \"conflict\" operation_conflict_encoding))\n (function Conflicting_ballot conflict -> Some conflict | _ -> None)\n (fun conflict -> Conflicting_ballot conflict)\nend\n\nmodule Anonymous = struct\n type error +=\n | Invalid_activation of {pkh : Ed25519.Public_key_hash.t}\n | Conflicting_activation of {\n edpkh : Ed25519.Public_key_hash.t;\n conflict : operation_conflict;\n }\n\n let () =\n register_error_kind\n `Permanent\n ~id:\"validate.operation.invalid_activation\"\n ~title:\"Invalid activation\"\n ~description:\n \"The given key and secret do not correspond to any existing \\\n preallocated contract.\"\n ~pp:(fun ppf pkh ->\n Format.fprintf\n ppf\n \"Invalid activation. The public key %a and accompanying secret do \\\n not match any commitment.\"\n Ed25519.Public_key_hash.pp\n pkh)\n Data_encoding.(obj1 (req \"pkh\" Ed25519.Public_key_hash.encoding))\n (function Invalid_activation {pkh} -> Some pkh | _ -> None)\n (fun pkh -> Invalid_activation {pkh}) ;\n register_error_kind\n `Branch\n ~id:\"validate.operation.conflicting_activation\"\n ~title:\"Account already activated in current validation_state\"\n ~description:\n \"The account has already been activated by a previous operation in the \\\n current validation state.\"\n ~pp:(fun ppf (edpkh, Operation_conflict {existing; _}) ->\n Format.fprintf\n ppf\n \"Invalid activation: the account %a has already been activated in \\\n the current validation state by operation %a.\"\n Ed25519.Public_key_hash.pp\n edpkh\n Operation_hash.pp\n existing)\n Data_encoding.(\n obj2\n (req \"edpkh\" Ed25519.Public_key_hash.encoding)\n (req \"conflict\" operation_conflict_encoding))\n (function\n | Conflicting_activation {edpkh; conflict} -> Some (edpkh, conflict)\n | _ -> None)\n (fun (edpkh, conflict) -> Conflicting_activation {edpkh; conflict})\n\n type denunciation_kind = Preendorsement | Endorsement | Block\n\n let denunciation_kind_encoding =\n let open Data_encoding in\n string_enum\n [\n (\"preendorsement\", Preendorsement);\n (\"endorsement\", Endorsement);\n (\"block\", Block);\n ]\n\n let pp_denunciation_kind fmt : denunciation_kind -> unit = function\n | Preendorsement -> Format.fprintf fmt \"preendorsement\"\n | Endorsement -> Format.fprintf fmt \"endorsement\"\n | Block -> Format.fprintf fmt \"block\"\n\n type error +=\n | Invalid_double_baking_evidence of {\n hash1 : Block_hash.t;\n level1 : Raw_level.t;\n round1 : Round.t;\n hash2 : Block_hash.t;\n level2 : Raw_level.t;\n round2 : Round.t;\n }\n | Invalid_denunciation of denunciation_kind\n | Inconsistent_denunciation of {\n kind : denunciation_kind;\n delegate1 : Signature.Public_key_hash.t;\n delegate2 : Signature.Public_key_hash.t;\n }\n | Already_denounced of {\n kind : denunciation_kind;\n delegate : Signature.Public_key_hash.t;\n level : Level.t;\n }\n | Conflicting_denunciation of {\n kind : denunciation_kind;\n conflict : operation_conflict;\n }\n | Too_early_denunciation of {\n kind : denunciation_kind;\n level : Raw_level.t;\n current : Raw_level.t;\n }\n | Outdated_denunciation of {\n kind : denunciation_kind;\n level : Raw_level.t;\n last_cycle : Cycle.t;\n }\n\n let () =\n register_error_kind\n `Permanent\n ~id:\"validate.block.invalid_double_baking_evidence\"\n ~title:\"Invalid double baking evidence\"\n ~description:\n \"A double-baking evidence is inconsistent (two distinct levels)\"\n ~pp:(fun ppf (hash1, level1, round1, hash2, level2, round2) ->\n Format.fprintf\n ppf\n \"Invalid double-baking evidence (hash: %a and %a, levels/rounds: \\\n (%ld,%ld) and (%ld,%ld))\"\n Block_hash.pp\n hash1\n Block_hash.pp\n hash2\n (Raw_level.to_int32 level1)\n (Round.to_int32 round1)\n (Raw_level.to_int32 level2)\n (Round.to_int32 round2))\n Data_encoding.(\n obj6\n (req \"hash1\" Block_hash.encoding)\n (req \"level1\" Raw_level.encoding)\n (req \"round1\" Round.encoding)\n (req \"hash2\" Block_hash.encoding)\n (req \"level2\" Raw_level.encoding)\n (req \"round2\" Round.encoding))\n (function\n | Invalid_double_baking_evidence\n {hash1; level1; round1; hash2; level2; round2} ->\n Some (hash1, level1, round1, hash2, level2, round2)\n | _ -> None)\n (fun (hash1, level1, round1, hash2, level2, round2) ->\n Invalid_double_baking_evidence\n {hash1; level1; round1; hash2; level2; round2}) ;\n register_error_kind\n `Permanent\n ~id:\"validate.operation.block.invalid_denunciation\"\n ~title:\"Invalid denunciation\"\n ~description:\"A denunciation is malformed\"\n ~pp:(fun ppf kind ->\n Format.fprintf\n ppf\n \"Malformed double-%a evidence\"\n pp_denunciation_kind\n kind)\n Data_encoding.(obj1 (req \"kind\" denunciation_kind_encoding))\n (function Invalid_denunciation kind -> Some kind | _ -> None)\n (fun kind -> Invalid_denunciation kind) ;\n register_error_kind\n `Permanent\n ~id:\"validate.operation.block.inconsistent_denunciation\"\n ~title:\"Inconsistent denunciation\"\n ~description:\n \"A denunciation operation is inconsistent (two distinct delegates)\"\n ~pp:(fun ppf (kind, delegate1, delegate2) ->\n Format.fprintf\n ppf\n \"Inconsistent double-%a evidence (distinct delegate: %a and %a)\"\n pp_denunciation_kind\n kind\n Signature.Public_key_hash.pp_short\n delegate1\n Signature.Public_key_hash.pp_short\n delegate2)\n Data_encoding.(\n obj3\n (req \"kind\" denunciation_kind_encoding)\n (req \"delegate1\" Signature.Public_key_hash.encoding)\n (req \"delegate2\" Signature.Public_key_hash.encoding))\n (function\n | Inconsistent_denunciation {kind; delegate1; delegate2} ->\n Some (kind, delegate1, delegate2)\n | _ -> None)\n (fun (kind, delegate1, delegate2) ->\n Inconsistent_denunciation {kind; delegate1; delegate2}) ;\n register_error_kind\n `Branch\n ~id:\"validate.operation.already_denounced\"\n ~title:\"Already denounced\"\n ~description:\"The same denunciation has already been validated.\"\n ~pp:(fun ppf (kind, delegate, level) ->\n Format.fprintf\n ppf\n \"Delegate %a at level %a has already been denounced for a double %a.\"\n pp_denunciation_kind\n kind\n Signature.Public_key_hash.pp\n delegate\n Level.pp\n level)\n Data_encoding.(\n obj3\n (req \"denunciation_kind\" denunciation_kind_encoding)\n (req \"delegate\" Signature.Public_key_hash.encoding)\n (req \"level\" Level.encoding))\n (function\n | Already_denounced {kind; delegate; level} ->\n Some (kind, delegate, level)\n | _ -> None)\n (fun (kind, delegate, level) -> Already_denounced {kind; delegate; level}) ;\n register_error_kind\n `Branch\n ~id:\"validate.operation.conflicting_denunciation\"\n ~title:\"Conflicting denunciation in current validation state\"\n ~description:\n \"The same denunciation has already been validated in the current \\\n validation state.\"\n ~pp:(fun ppf (kind, Operation_conflict {existing; _}) ->\n Format.fprintf\n ppf\n \"Double %a evidence already exists in the current validation state \\\n as operation %a.\"\n pp_denunciation_kind\n kind\n Operation_hash.pp\n existing)\n Data_encoding.(\n obj2\n (req \"denunciation_kind\" denunciation_kind_encoding)\n (req \"conflict\" operation_conflict_encoding))\n (function\n | Conflicting_denunciation {kind; conflict} -> Some (kind, conflict)\n | _ -> None)\n (fun (kind, conflict) -> Conflicting_denunciation {kind; conflict}) ;\n register_error_kind\n `Temporary\n ~id:\"validate.operation.block.too_early_denunciation\"\n ~title:\"Too early denunciation\"\n ~description:\"A denunciation is too far in the future\"\n ~pp:(fun ppf (kind, level, current) ->\n Format.fprintf\n ppf\n \"A double-%a denunciation is too far in the future (current level: \\\n %a, given level: %a)\"\n pp_denunciation_kind\n kind\n Raw_level.pp\n current\n Raw_level.pp\n level)\n Data_encoding.(\n obj3\n (req \"kind\" denunciation_kind_encoding)\n (req \"level\" Raw_level.encoding)\n (req \"current\" Raw_level.encoding))\n (function\n | Too_early_denunciation {kind; level; current} ->\n Some (kind, level, current)\n | _ -> None)\n (fun (kind, level, current) ->\n Too_early_denunciation {kind; level; current}) ;\n register_error_kind\n `Permanent\n ~id:\"validate.operation.block.outdated_denunciation\"\n ~title:\"Outdated denunciation\"\n ~description:\"A denunciation is outdated.\"\n ~pp:(fun ppf (kind, level, last_cycle) ->\n Format.fprintf\n ppf\n \"A double-%a denunciation is outdated (last acceptable cycle: %a, \\\n given level: %a).\"\n pp_denunciation_kind\n kind\n Cycle.pp\n last_cycle\n Raw_level.pp\n level)\n Data_encoding.(\n obj3\n (req \"kind\" denunciation_kind_encoding)\n (req \"level\" Raw_level.encoding)\n (req \"last\" Cycle.encoding))\n (function\n | Outdated_denunciation {kind; level; last_cycle} ->\n Some (kind, level, last_cycle)\n | _ -> None)\n (fun (kind, level, last_cycle) ->\n Outdated_denunciation {kind; level; last_cycle})\n\n type error += Conflicting_nonce_revelation of operation_conflict\n\n let () =\n register_error_kind\n `Branch\n ~id:\"validate.operation.conflicting_nonce_revelation\"\n ~title:\"Conflicting nonce revelation in the current validation state).\"\n ~description:\n \"A revelation for the same nonce has already been validated for the \\\n current validation state.\"\n ~pp:(fun ppf (Operation_conflict {existing; _}) ->\n Format.fprintf\n ppf\n \"This nonce revelation is conflicting with an existing revelation %a\"\n Operation_hash.pp\n existing)\n Data_encoding.(obj1 (req \"conflict\" operation_conflict_encoding))\n (function\n | Conflicting_nonce_revelation conflict -> Some conflict | _ -> None)\n (fun conflict -> Conflicting_nonce_revelation conflict)\n\n type error += Conflicting_vdf_revelation of operation_conflict\n\n let () =\n register_error_kind\n `Branch\n ~id:\"validate.operation.conflicting_vdf_revelation\"\n ~title:\"Conflicting vdf revelation in the current validation state).\"\n ~description:\n \"A revelation for the same vdf has already been validated for the \\\n current validation state.\"\n ~pp:(fun ppf (Operation_conflict {existing; _}) ->\n Format.fprintf\n ppf\n \"This vdf revelation is conflicting with an existing revelation %a\"\n Operation_hash.pp\n existing)\n Data_encoding.(obj1 (req \"conflict\" operation_conflict_encoding))\n (function\n | Conflicting_vdf_revelation conflict -> Some conflict | _ -> None)\n (fun conflict -> Conflicting_vdf_revelation conflict)\n\n type error +=\n | Drain_delegate_on_unregistered_delegate of Signature.Public_key_hash.t\n | Invalid_drain_delegate_inactive_key of {\n delegate : Signature.Public_key_hash.t;\n consensus_key : Signature.Public_key_hash.t;\n active_consensus_key : Signature.Public_key_hash.t;\n }\n | Invalid_drain_delegate_no_consensus_key of Signature.Public_key_hash.t\n | Invalid_drain_delegate_noop of Signature.Public_key_hash.t\n | Invalid_drain_delegate_insufficient_funds_for_burn_or_fees of {\n delegate : Signature.Public_key_hash.t;\n destination : Signature.Public_key_hash.t;\n min_amount : Tez.t;\n }\n | Conflicting_drain_delegate of {\n delegate : Signature.Public_key_hash.t;\n conflict : operation_conflict;\n }\n\n let () =\n register_error_kind\n `Temporary\n ~id:\"operation.drain_delegate_key_on_unregistered_delegate\"\n ~title:\"Drain delegate key on an unregistered delegate\"\n ~description:\"Cannot drain an unregistered delegate.\"\n ~pp:(fun ppf c ->\n Format.fprintf\n ppf\n \"Cannot drain an unregistered delegate %a.\"\n Signature.Public_key_hash.pp\n c)\n Data_encoding.(obj1 (req \"delegate\" Signature.Public_key_hash.encoding))\n (function\n | Drain_delegate_on_unregistered_delegate c -> Some c | _ -> None)\n (fun c -> Drain_delegate_on_unregistered_delegate c) ;\n register_error_kind\n `Temporary\n ~id:\"operation.invalid_drain.inactive_key\"\n ~title:\"Drain delegate with an inactive consensus key\"\n ~description:\"Cannot drain with an inactive consensus key.\"\n ~pp:(fun ppf (delegate, consensus_key, active_consensus_key) ->\n Format.fprintf\n ppf\n \"Consensus key %a is not the active consensus key for delegate %a. \\\n The active consensus key is %a.\"\n Signature.Public_key_hash.pp\n consensus_key\n Signature.Public_key_hash.pp\n delegate\n Signature.Public_key_hash.pp\n active_consensus_key)\n Data_encoding.(\n obj3\n (req \"delegate\" Signature.Public_key_hash.encoding)\n (req \"consensus_key\" Signature.Public_key_hash.encoding)\n (req \"active_consensus_key\" Signature.Public_key_hash.encoding))\n (function\n | Invalid_drain_delegate_inactive_key\n {delegate; consensus_key; active_consensus_key} ->\n Some (delegate, consensus_key, active_consensus_key)\n | _ -> None)\n (fun (delegate, consensus_key, active_consensus_key) ->\n Invalid_drain_delegate_inactive_key\n {delegate; consensus_key; active_consensus_key}) ;\n register_error_kind\n `Temporary\n ~id:\"operation.invalid_drain.no_consensus_key\"\n ~title:\"Drain a delegate without consensus key\"\n ~description:\"Cannot drain a delegate without consensus key.\"\n ~pp:(fun ppf delegate ->\n Format.fprintf\n ppf\n \"There is no active consensus key for delegate %a.\"\n Signature.Public_key_hash.pp\n delegate)\n Data_encoding.(obj1 (req \"delegate\" Signature.Public_key_hash.encoding))\n (function\n | Invalid_drain_delegate_no_consensus_key c -> Some c | _ -> None)\n (fun c -> Invalid_drain_delegate_no_consensus_key c) ;\n register_error_kind\n `Temporary\n ~id:\"operation.invalid_drain.noop\"\n ~title:\"Invalid drain delegate: noop\"\n ~description:\"Cannot drain a delegate to itself.\"\n ~pp:(fun ppf delegate ->\n Format.fprintf\n ppf\n \"The destination of a drain operation cannot be the delegate itself \\\n (%a).\"\n Signature.Public_key_hash.pp\n delegate)\n Data_encoding.(obj1 (req \"delegate\" Signature.Public_key_hash.encoding))\n (function Invalid_drain_delegate_noop c -> Some c | _ -> None)\n (fun c -> Invalid_drain_delegate_noop c) ;\n register_error_kind\n `Temporary\n ~id:\"operation.invalid_drain.insufficient_funds_for_burn_or_fees\"\n ~title:\n \"Drain delegate without enough balance for allocation burn or drain \\\n fees\"\n ~description:\"Cannot drain without enough allocation burn and drain fees.\"\n ~pp:(fun ppf (delegate, destination, min_amount) ->\n Format.fprintf\n ppf\n \"Cannot drain delegate from %a to %a: not enough funds for the drain \\\n fees in the delegate account (minimum balance required: %a).\"\n Signature.Public_key_hash.pp\n delegate\n Signature.Public_key_hash.pp\n destination\n Tez.pp\n min_amount)\n Data_encoding.(\n obj3\n (req \"delegate\" Signature.Public_key_hash.encoding)\n (req \"destination\" Signature.Public_key_hash.encoding)\n (req \"min_amount\" Tez.encoding))\n (function\n | Invalid_drain_delegate_insufficient_funds_for_burn_or_fees\n {delegate; destination; min_amount} ->\n Some (delegate, destination, min_amount)\n | _ -> None)\n (fun (delegate, destination, min_amount) ->\n Invalid_drain_delegate_insufficient_funds_for_burn_or_fees\n {delegate; destination; min_amount}) ;\n register_error_kind\n `Branch\n ~id:\"validate.operation.conflicting_drain\"\n ~title:\"Conflicting drain in the current validation state).\"\n ~description:\n \"A manager operation or another drain operation is in conflict.\"\n ~pp:(fun ppf (delegate, Operation_conflict {existing; _}) ->\n Format.fprintf\n ppf\n \"This drain operation conflicts with operation %a for the delegate %a\"\n Operation_hash.pp\n existing\n Signature.Public_key_hash.pp\n delegate)\n Data_encoding.(\n obj2\n (req \"delegate\" Signature.Public_key_hash.encoding)\n (req \"conflict\" operation_conflict_encoding))\n (function\n | Conflicting_drain_delegate {delegate; conflict} ->\n Some (delegate, conflict)\n | _ -> None)\n (fun (delegate, conflict) ->\n Conflicting_drain_delegate {delegate; conflict})\nend\n\nmodule Manager = struct\n type error +=\n | Manager_restriction of {\n source : Signature.Public_key_hash.t;\n conflict : operation_conflict;\n }\n | Inconsistent_sources\n | Inconsistent_counters\n | Incorrect_reveal_position\n | Insufficient_gas_for_manager\n | Gas_quota_exceeded_init_deserialize\n | Tx_rollup_feature_disabled\n | Sc_rollup_feature_disabled\n | Sc_rollup_arith_pvm_disabled\n | Zk_rollup_feature_disabled\n\n let () =\n register_error_kind\n `Temporary\n ~id:\"validate.operation.manager_restriction\"\n ~title:\"Manager restriction\"\n ~description:\n \"An operation with the same manager has already been validated in the \\\n current block.\"\n ~pp:(fun ppf (source, Operation_conflict {existing; _}) ->\n Format.fprintf\n ppf\n \"Manager %a already has the operation %a in the current block.\"\n Signature.Public_key_hash.pp\n source\n Operation_hash.pp\n existing)\n Data_encoding.(\n obj2\n (req \"source\" Signature.Public_key_hash.encoding)\n (req \"conflict\" operation_conflict_encoding))\n (function\n | Manager_restriction {source; conflict} -> Some (source, conflict)\n | _ -> None)\n (fun (source, conflict) -> Manager_restriction {source; conflict}) ;\n let inconsistent_sources_description =\n \"The operation batch includes operations from different sources.\"\n in\n register_error_kind\n `Permanent\n ~id:\"validate.operation.inconsistent_sources\"\n ~title:\"Inconsistent sources in operation batch\"\n ~description:inconsistent_sources_description\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"%s\" inconsistent_sources_description)\n Data_encoding.empty\n (function Inconsistent_sources -> Some () | _ -> None)\n (fun () -> Inconsistent_sources) ;\n let inconsistent_counters_description =\n \"Inconsistent counters in operation. Counters of an operation must be \\\n successive.\"\n in\n register_error_kind\n `Permanent\n ~id:\"validate.operation.inconsistent_counters\"\n ~title:\"Inconsistent counters in operation\"\n ~description:inconsistent_counters_description\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"%s\" inconsistent_counters_description)\n Data_encoding.empty\n (function Inconsistent_counters -> Some () | _ -> None)\n (fun () -> Inconsistent_counters) ;\n let incorrect_reveal_description =\n \"Incorrect reveal operation position in batch: only allowed in first \\\n position.\"\n in\n register_error_kind\n `Permanent\n ~id:\"validate.operation.incorrect_reveal_position\"\n ~title:\"Incorrect reveal position\"\n ~description:incorrect_reveal_description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" incorrect_reveal_description)\n Data_encoding.empty\n (function Incorrect_reveal_position -> Some () | _ -> None)\n (fun () -> Incorrect_reveal_position) ;\n register_error_kind\n `Permanent\n ~id:\"validate.operation.insufficient_gas_for_manager\"\n ~title:\"Not enough gas for initial manager cost\"\n ~description:\n (Format.asprintf\n \"Gas limit is too low to cover the initial cost of manager \\\n operations: a minimum of %a gas units is required.\"\n Gas.pp_cost_as_gas\n Michelson_v1_gas.Cost_of.manager_operation)\n Data_encoding.empty\n (function Insufficient_gas_for_manager -> Some () | _ -> None)\n (fun () -> Insufficient_gas_for_manager) ;\n let gas_deserialize_description =\n \"Gas limit was not high enough to deserialize the transaction parameters \\\n or origination script code or initial storage etc., making the \\\n operation impossible to parse within the provided gas bounds.\"\n in\n register_error_kind\n `Permanent\n ~id:\"validate.operation.gas_quota_exceeded_init_deserialize\"\n ~title:\"Not enough gas for initial deserialization of script expressions\"\n ~description:gas_deserialize_description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" gas_deserialize_description)\n Data_encoding.empty\n (function Gas_quota_exceeded_init_deserialize -> Some () | _ -> None)\n (fun () -> Gas_quota_exceeded_init_deserialize) ;\n register_error_kind\n `Permanent\n ~id:\"validate.operation.tx_rollup_is_disabled\"\n ~title:\"Tx rollup is disabled\"\n ~description:\"Cannot originate a tx rollup as it is disabled.\"\n ~pp:(fun ppf () ->\n Format.fprintf\n ppf\n \"Cannot apply a tx rollup operation as it is disabled. This feature \\\n will be enabled in a future proposal\")\n Data_encoding.unit\n (function Tx_rollup_feature_disabled -> Some () | _ -> None)\n (fun () -> Tx_rollup_feature_disabled) ;\n let scoru_disabled_description = \"Smart rollups are disabled.\" in\n register_error_kind\n `Permanent\n ~id:\"validate.operation.smart_rollup_disabled\"\n ~title:\"Smart rollups are disabled\"\n ~description:scoru_disabled_description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" scoru_disabled_description)\n Data_encoding.unit\n (function Sc_rollup_feature_disabled -> Some () | _ -> None)\n (fun () -> Sc_rollup_feature_disabled) ;\n\n let scoru_arith_pvm_disabled_description =\n \"Arith PVM is disabled in this network.\"\n in\n register_error_kind\n `Permanent\n ~id:\"operation.arith_pvm_disabled\"\n ~title:\"The Arith PVM is disabled\"\n ~description:scoru_arith_pvm_disabled_description\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"%s\" scoru_arith_pvm_disabled_description)\n Data_encoding.unit\n (function Sc_rollup_arith_pvm_disabled -> Some () | _ -> None)\n (fun () -> Sc_rollup_arith_pvm_disabled) ;\n let zkru_disabled_description =\n \"ZK rollups will be enabled in a future proposal.\"\n in\n register_error_kind\n `Permanent\n ~id:\"validate.operation.zk_rollup_disabled\"\n ~title:\"ZK rollups are disabled\"\n ~description:zkru_disabled_description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" zkru_disabled_description)\n Data_encoding.unit\n (function Zk_rollup_feature_disabled -> Some () | _ -> None)\n (fun () -> Zk_rollup_feature_disabled)\nend\n\ntype error += Failing_noop_error\n\nlet () =\n let description = \"A failing_noop operation can never be validated.\" in\n register_error_kind\n `Permanent\n ~id:\"validate.operation.failing_noop_error\"\n ~title:\"Failing_noop error\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Failing_noop_error -> Some () | _ -> None)\n (fun () -> Failing_noop_error)\n\nmodule Block = struct\n type error +=\n | Not_enough_endorsements of {required : int; provided : int}\n | Inconsistent_validation_passes_in_block of {\n expected : int;\n provided : int;\n }\n\n let () =\n register_error_kind\n `Permanent\n ~id:\"validate.block.not_enough_endorsements\"\n ~title:\"Not enough endorsements\"\n ~description:\n \"The block being validated does not include the required minimum \\\n number of endorsements.\"\n ~pp:(fun ppf (required, provided) ->\n Format.fprintf\n ppf\n \"Wrong number of endorsements (%i), at least %i are expected\"\n provided\n required)\n Data_encoding.(obj2 (req \"required\" int31) (req \"provided\" int31))\n (function\n | Not_enough_endorsements {required; provided} ->\n Some (required, provided)\n | _ -> None)\n (fun (required, provided) -> Not_enough_endorsements {required; provided}) ;\n register_error_kind\n `Permanent\n ~id:\"validate.block.inconsistent_validation_passes_in_block\"\n ~title:\"Inconsistent validation passes in block\"\n ~description:\n \"Validation of operation should be ordered by their validation passes \\\n in a block.\"\n ~pp:(fun ppf (expected, provided) ->\n Format.fprintf\n ppf\n \"Validation of operation should be ordered by their validation \\\n passes in a block. Got an operation with validation pass: %d while \\\n the last validated operation had the validation pass %d.\"\n provided\n expected)\n Data_encoding.(obj2 (req \"expected\" int31) (req \"provided\" int31))\n (function\n | Inconsistent_validation_passes_in_block {expected; provided} ->\n Some (expected, provided)\n | _ -> None)\n (fun (expected, provided) ->\n Inconsistent_validation_passes_in_block {expected; provided})\nend\n" ;
} ;
{ name = "Amendment" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(**\n Amendments and proposals.\n\n Only delegates having the minimal required stake take part in the amendment\n procedure. It works as follows:\n\n - Proposal period: delegates can submit protocol amendment\n proposals using the proposal operation. At the end of a proposal\n period, the proposal with most supporters is selected and we move\n to an exploration period. If there are no proposals, or a tie\n between proposals, a new proposal period starts.\n\n - Exploration period: delegates can cast votes to test or not the\n winning proposal using the ballot operation. At the end of an\n exploration period if participation reaches the quorum and the\n proposal has a supermajority in favor, we proceed to a cooldown\n period. Otherwise we go back to a proposal period. In any case, if\n there is enough participation the quorum is updated.\n\n - Cooldown period: business as usual for the main chain. This\n period is only a time gap between exploration and promotion\n periods intended to provide the community with extra time to\n continue testing the new protocol proposal, and start adapting\n their infrastructure in advance. At the end of the Cooldown\n period we move to the Promotion period.\n\n - Promotion period: delegates can cast votes to promote or not the\n proposal using the ballot operation. At the end of a promotion\n period if participation reaches the quorum and the proposal has a\n supermajority in favor, we move to an adoption period. Otherwise we\n go back to a proposal period. In any case, if there is enough\n participation the quorum is updated.\n\n - Adoption period: At the end of an adoption period, the proposal\n is activated as the new protocol.\n\n The current protocol parameters are documented in\n src/proto_alpha/lib_parameters/default_parameters.ml\n\n In practice, the real constants used are defined in the\n migration code. In src/proto_alpha/lib_protocol/init_storage.ml,\n function [prepare_first_block] introduces new constants and\n redefines the existing ones.\n*)\n\nopen Alpha_context\n\n(** If at the end of a voting period, moves to the next one following\n the state machine of the amendment procedure. *)\nval may_start_new_voting_period : context -> context tzresult Lwt.t\n\n(** Return the registered testchain dictator, if any. This function will always\n return None on mainnet. *)\nval get_testnet_dictator : context -> Chain_id.t -> public_key_hash option\n\n(** Check whether the given public key hash corresponds to the\n registered testchain dictator, if any. This function will always\n return false on mainnet. *)\nval is_testnet_dictator : context -> Chain_id.t -> public_key_hash -> bool\n\n(** {2 Application of voting operations}\n\n There are two kinds of voting operations:\n\n - Proposals: A delegate submits a list of protocol amendment\n proposals. This operation is only accepted during a Proposal period\n (see above).\n\n - Ballot: A delegate casts a vote for/against the current proposal\n (or pass). This operation is only accepted during an Exploration\n or Promotion period (see above). *)\n\n(** Update the [context] with the effects of a Proposals operation:\n\n - Its proposals are added to the source's recorded proposals.\n\n - The recorded proposal count of the source is increased by the\n number of proposals in the operation.\n\n Note that a Proposals operation from a testnet dictator (which may\n be set up when a test chain is initialized) has completely\n different effects:\n\n - If the operation contains no proposal, then the current voting\n period is immediately and forcibly set to a Proposal period.\n\n - If the operation contains exactly one proposal, then the current\n voting period is immediately and forcibly set to an Adoption period\n for this proposal.\n\n {!validate_proposals} must have been called beforehand, and is\n responsible for ensuring that [apply_proposals] cannot fail. *)\nval apply_proposals :\n context ->\n Chain_id.t ->\n Kind.proposals contents ->\n (context * Kind.proposals Apply_results.contents_result_list) tzresult Lwt.t\n\n(** Update the [context] with the effects of a Ballot operation:\n\n The couple (source of the operation, submitted ballot) is recorded.\n\n {!validate_ballot} must have been called beforehand, and is\n responsible for ensuring that [apply_ballot] cannot fail. *)\nval apply_ballot :\n context ->\n Kind.ballot contents ->\n (context * Kind.ballot Apply_results.contents_result_list) tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\n(** Returns the proposal submitted by the most delegates.\n Returns None in case of a tie, if proposal quorum is below required\n minimum or if there are no proposals. *)\nlet select_winning_proposal ctxt =\n Vote.get_proposals ctxt >>=? fun proposals ->\n let merge proposal vote winners =\n match winners with\n | None -> Some ([proposal], vote)\n | Some (winners, winners_vote) as previous ->\n if Compare.Int64.(vote = winners_vote) then\n Some (proposal :: winners, winners_vote)\n else if Compare.Int64.(vote > winners_vote) then Some ([proposal], vote)\n else previous\n in\n match Protocol_hash.Map.fold merge proposals None with\n | Some ([proposal], vote) ->\n Vote.get_total_voting_power_free ctxt >>=? fun max_vote ->\n let min_proposal_quorum =\n Z.of_int32 (Constants.min_proposal_quorum ctxt)\n in\n let min_vote_to_pass =\n Z.(\n to_int64\n (div (mul min_proposal_quorum (of_int64 max_vote)) (of_int 100_00)))\n in\n if Compare.Int64.(vote >= min_vote_to_pass) then return_some proposal\n else return_none\n | _ -> return_none\n\n(* in case of a tie, let's do nothing. *)\n\n(** A proposal is approved if it has supermajority and the participation reaches\n the current quorum.\n Supermajority means the yays are more 8/10 of casted votes.\n The participation is the ratio of all received votes, including passes, with\n respect to the number of possible votes.\n The participation EMA (exponential moving average) uses the last\n participation EMA and the current participation./\n The expected quorum is calculated using the last participation EMA, capped\n by the min/max quorum protocol constants. *)\nlet approval_and_participation_ema (ballots : Vote.ballots) ~maximum_vote\n ~participation_ema ~expected_quorum =\n (* Note overflows: considering a maximum of 1e9 tokens (around 2^30),\n hence 1e15 mutez (around 2^50)\n In 'participation' a Z is used because in the worst case 'all_votes is\n 1e15 and after the multiplication is 1e19 (around 2^64).\n *)\n let casted_votes = Int64.add ballots.yay ballots.nay in\n let all_votes = Int64.add casted_votes ballots.pass in\n let supermajority = Int64.div (Int64.mul 8L casted_votes) 10L in\n let participation =\n (* in centile of percentage *)\n Z.(\n to_int32\n (div\n (mul (Z.of_int64 all_votes) (Z.of_int 100_00))\n (Z.of_int64 maximum_vote)))\n in\n let approval =\n Compare.Int32.(participation >= expected_quorum)\n && Compare.Int64.(ballots.yay >= supermajority)\n in\n let new_participation_ema =\n Int32.(div (add (mul 8l participation_ema) (mul 2l participation)) 10l)\n in\n (approval, new_participation_ema)\n\nlet get_approval_and_update_participation_ema ctxt =\n Vote.get_ballots ctxt >>=? fun ballots ->\n Vote.get_total_voting_power_free ctxt >>=? fun maximum_vote ->\n Vote.get_participation_ema ctxt >>=? fun participation_ema ->\n Vote.get_current_quorum ctxt >>=? fun expected_quorum ->\n Vote.clear_ballots ctxt >>= fun ctxt ->\n let approval, new_participation_ema =\n approval_and_participation_ema\n ballots\n ~maximum_vote\n ~participation_ema\n ~expected_quorum\n in\n Vote.set_participation_ema ctxt new_participation_ema >|=? fun ctxt ->\n (ctxt, approval)\n\n(** Implements the state machine of the amendment procedure. Note that\n [update_listings], that computes the vote weight of each delegate, is run at\n the end of each voting period. This state-machine prepare the voting_period\n for the next block. *)\nlet start_new_voting_period ctxt =\n (* any change related to the storage in this function must probably\n be replicated in `record_testnet_dictator_proposals` *)\n Voting_period.get_current_kind ctxt >>=? fun kind ->\n (match kind with\n | Proposal -> (\n select_winning_proposal ctxt >>=? fun proposal ->\n Vote.clear_proposals ctxt >>= fun ctxt ->\n match proposal with\n | None -> Voting_period.reset ctxt\n | Some proposal ->\n Vote.init_current_proposal ctxt proposal >>=? Voting_period.succ)\n | Exploration ->\n get_approval_and_update_participation_ema ctxt\n >>=? fun (ctxt, approved) ->\n if approved then Voting_period.succ ctxt\n else\n Vote.clear_current_proposal ctxt >>= fun ctxt ->\n Voting_period.reset ctxt\n | Cooldown -> Voting_period.succ ctxt\n | Promotion ->\n get_approval_and_update_participation_ema ctxt\n >>=? fun (ctxt, approved) ->\n if approved then Voting_period.succ ctxt\n else Vote.clear_current_proposal ctxt >>= Voting_period.reset\n | Adoption ->\n Vote.get_current_proposal ctxt >>=? fun proposal ->\n activate ctxt proposal >>= fun ctxt ->\n Vote.clear_current_proposal ctxt >>= Voting_period.reset)\n >>=? fun ctxt -> Vote.update_listings ctxt\n\nlet may_start_new_voting_period ctxt =\n Voting_period.is_last_block ctxt >>=? fun is_last ->\n if is_last then start_new_voting_period ctxt else return ctxt\n\n(** {2 Application of voting operations} *)\n\nlet get_testnet_dictator ctxt chain_id =\n (* This function should always, ALWAYS, return None on mainnet!!!! *)\n match Constants.testnet_dictator ctxt with\n | Some pkh when Chain_id.(chain_id <> Constants.mainnet_id) -> Some pkh\n | _ -> None\n\nlet is_testnet_dictator ctxt chain_id delegate =\n (* This function should always, ALWAYS, return false on mainnet!!!! *)\n match get_testnet_dictator ctxt chain_id with\n | Some pkh -> Signature.Public_key_hash.equal pkh delegate\n | _ -> false\n\n(** Apply a [Proposals] operation from a registered dictator of a test\n chain. This forcibly updates the voting period, changing the\n current voting period kind and the current proposal if\n applicable. Of course, there must never be such a dictator on\n mainnet: see {!is_testnet_dictator}. *)\nlet apply_testnet_dictator_proposals ctxt chain_id proposals =\n let open Lwt_result_syntax in\n let*! ctxt = Vote.clear_ballots ctxt in\n let*! ctxt = Vote.clear_proposals ctxt in\n let*! ctxt = Vote.clear_current_proposal ctxt in\n let ctxt = record_dictator_proposal_seen ctxt in\n match proposals with\n | [] ->\n Voting_period.Testnet_dictator.overwrite_current_kind\n ctxt\n chain_id\n Proposal\n | [proposal] ->\n let* ctxt = Vote.init_current_proposal ctxt proposal in\n Voting_period.Testnet_dictator.overwrite_current_kind\n ctxt\n chain_id\n Adoption\n | _ :: _ :: _ ->\n (* This case should not be possible if the operation has been\n previously validated by {!Validate.validate_operation}. *)\n tzfail Validate_errors.Voting.Testnet_dictator_multiple_proposals\n\nlet apply_proposals ctxt chain_id (Proposals {source; period = _; proposals}) =\n let open Lwt_result_syntax in\n let* ctxt =\n if is_testnet_dictator ctxt chain_id source then\n apply_testnet_dictator_proposals ctxt chain_id proposals\n else if dictator_proposal_seen ctxt then\n (* Noop if dictator voted *)\n return ctxt\n else\n let* count = Vote.get_delegate_proposal_count ctxt source in\n let new_count = count + List.length proposals in\n let*! ctxt = Vote.set_delegate_proposal_count ctxt source new_count in\n let*! ctxt =\n List.fold_left_s\n (fun ctxt proposal -> Vote.add_proposal ctxt source proposal)\n ctxt\n proposals\n in\n return ctxt\n in\n return (ctxt, Apply_results.Single_result Proposals_result)\n\nlet apply_ballot ctxt (Ballot {source; period = _; proposal = _; ballot}) =\n let open Lwt_result_syntax in\n let* ctxt =\n if dictator_proposal_seen ctxt then (* Noop if dictator voted *) return ctxt\n else Vote.record_ballot ctxt source ballot\n in\n return (ctxt, Apply_results.Single_result Ballot_result)\n" ;
} ;
{ name = "Validate" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module provides functions pertaining to the validation of\n blocks and operations. Most elements in this module are either used\n or wrapped in the {!Main} module (though some of them are also\n directly used by the plugin).\n\n The purpose of validation is to decide quickly whether a block or\n an operation is valid, with minimal computations and without\n writing anything in the storage. A block is considered valid if it\n can be applied without failure (see {!Apply}). An operation is\n valid if it can be safely included in a block without causing it to\n fail. Therefore, the current module is responsible for ensuring\n that calling functions from {!Apply} on validated blocks and\n operations will not fail.\n\n {2 Block validation}\n\n The process of validation of a block may be started by calling one\n of the following functions, depending on the circumstances (aka\n mode):\n\n - [begin_application] is used for the validation of a preexisting\n block, typically received through the network, and usually in\n preparation for its future application.\n\n - [begin_partial_validation] is used to quickly but partially\n validate an existing block. It is intended for quickly assessing a\n series of blocks in an alternate branch (multipass validation). For\n this reason, in this mode, the initial {!Alpha_context.t} may be\n based on an ancestor block of the block to validate, instead of\n necessarily its predecessor as in other modes.\n\n - [begin_full_construction] is used for the construction of a new\n block, typically by a baker.\n\n Then, [validate_operation] should be called on every operation in\n the block (in order of validation pass: see\n {!Operation_repr.acceptable_pass}). Lastly, [finalize_block]\n performs final checks on the block; if this function succeeds then\n the block is valid.\n\n {2 Validation state}\n\n The process of block validation relies on a [validation_state]\n transmitted throughout the aforementioned function calls. More\n precisely, this immutable functional state is initialized by the\n [begin_...] functions, read and updated by [validate_operation]\n (as in, a slightly different [validation_state] is returned), and\n required by [finalize_block]. It consists in three fields:\n\n - [info] contains static information required by\n [validate_operation] and [finalize_block], notably the initial\n {!Alpha_context.t}. It is fully filled in by the [begin_...]\n functions, then only read, never updated.\n\n - [operation_conflict_state] keeps track of every validated\n operation in the block, so that it can detect any conflict between\n operations (e.g. two manager operations from the same\n source). Consequently, it is both filled in and read by\n [validate_operation], but not used at all by [finalize_block].\n\n - [block_state] registers global block metrics such as total gas\n used or endorsement power. It is filled in by [validate_operation],\n which also uses it, e.g. to immediately return an error if the\n block gas limit is exceeded. It is also essential to several checks\n in [finalize_block].\n\n The immutability of the [validation_state] allows the caller to\n pause, replay, or backtrack throughout the steps of the validation\n process.\n\n {2 Operation validation}\n\n Operations may be validated either as part of the validation of a\n block in which they are included (see above), or on their own:\n\n - [begin_partial_construction] allows to initialize a\n [validation_state] for the validation of operations outside of the\n process of validation of a block. It is intended for mempools (see\n {!Mempool_validation}) and for some RPCs. The global block\n properties such as total block gas and endorsement power are not\n checked. Calling [finalize_block] on such a [validation_state] does\n not make much sense and simply returns unit.\n\n - [begin_no_predecessor_info] is a special weaker version of\n [begin_partial_construction]: see its own documentation below.\n\n Even outside of the context of a given block validation, the\n validation of operations aims at deciding whether they could\n theoretically be included in a future block. Indeed, for a mempool,\n this means that they are worth transmitting to a baker and\n propagating to peers; or for the caller of an RPC, it means that\n the tested operations may be injected in the node.\n\n An important property to maintain is that applying (see\n {!Apply.apply_operation}) any subset of validated operations should\n always succeed, even if they are not applied in the same order as\n they were validated (as long as the order of application respects\n the validation passes ordering). In other words, for all operations\n A and B that have both been validated: if A has an earlier or the\n same validation pass as B, then applying A then B must succeed; and\n if B has an earlier or the same validation pass as A, then applying\n B then A must succeed. Some restrictions, such as\n one-operation-per-manager-per-block (1M), have been introduced to\n preserve this property, and are enforced with the help of the\n [operation_conflict_state]. An important consequence of this\n property is that a baker may select any subset of validated\n operations to bake into a new block, which is then guaranteed to be\n applicable (provided that it verifies some additional global\n properties such as including enough (pre)endorsing power; the baker\n is responsible for ensuring this).\n\n For a manager operation, validity is mainly solvability, ie. the\n operation must be well-formed and we must be able to take its\n fees. Indeed, this is sufficient for the safe inclusion of the\n operation in a block: even if there is an error during the\n subsequent application of the manager operation, this will cause\n the operation to have no further effects, but won't impact the\n success of the block's application. The solvability of a manager\n operation notably requires that it is correctly signed: indeed, we\n can't take anything from a manager without having checked their\n signature.\n\n A non-manager operation is only valid if its effects can be fully\n applied in an {!Alpha_context.t} without failure. Indeed, any error\n during the application of such an operation would cause the whole\n block to fail; unlike manager operations, there is no notion of\n failing to have an effect without impacting the application of the\n whole block. More detailled documentation on checks performed and\n potential errors can be found in the [validate.ml] file for some\n non-manager operations. *)\n\nopen Alpha_context\nopen Validate_errors\n\n(** Static information required to validate blocks and operations. *)\ntype info\n\n(** State used to keep track of previously validated operations and\n detect potential conflicts. This state is serializable which allows\n it to be exchanged with another source. See {!Mempool_validation}. *)\ntype operation_conflict_state\n\n(** Encoding for the [operation_conflict_state]. *)\nval operation_conflict_state_encoding : operation_conflict_state Data_encoding.t\n\n(** State used to register global block properties which are relevant\n to the validity of a block, e.g. the total gas used in the block so\n far. This state is both used and updated by the [validate_operation]\n function, and is also required by [finalize_block]. *)\ntype block_state\n\n(** Validation state (see above). *)\ntype validation_state = {\n info : info;\n operation_state : operation_conflict_state;\n block_state : block_state;\n}\n\n(** Return the context stored in the state.\n\n Note that this is the context at the beginning of the block /\n mempool: indeed, it is not modified by [validate_operation]. *)\nval get_initial_ctxt : validation_state -> context\n\n(** Initialize the {!validation_state} for the validation of an\n existing block, usually in preparation for its future application. *)\nval begin_application :\n context ->\n Chain_id.t ->\n predecessor_level:Level.t ->\n predecessor_timestamp:Time.t ->\n Block_header.t ->\n Fitness.t ->\n validation_state tzresult Lwt.t\n\n(** Initialize the {!validation_state} for the partial validation of\n an existing block.\n\n The partial validation mode is intended for quickly assessing a\n series of blocks in a cousin branch (multipass\n validation). Therefore, it is the only mode in which the given\n {!type:context} may be based on any recent ancestor block of the\n block to validate, instead of only its predecessor (where recent\n means having a greater level than the [last_allowed_fork_level] of\n the current head). *)\nval begin_partial_validation :\n context ->\n Chain_id.t ->\n predecessor_level:Level.t ->\n predecessor_timestamp:Time.t ->\n Block_header.t ->\n Fitness.t ->\n validation_state tzresult Lwt.t\n\n(** Initialize the {!validation_state} for the full construction of a\n fresh block. *)\nval begin_full_construction :\n context ->\n Chain_id.t ->\n predecessor_level:Level.t ->\n predecessor_round:Round.t ->\n predecessor_timestamp:Time.t ->\n predecessor_hash:Block_hash.t ->\n Round.t ->\n Block_header.contents ->\n validation_state tzresult Lwt.t\n\n(** Initialize the {!validation_state} for the validation of\n operations outside of the process of validation of a block. The\n partial construction mode is mainly used to implement the mempool\n (see {!Mempool_validation}), but may also be used by some RPCs. *)\nval begin_partial_construction :\n context ->\n Chain_id.t ->\n predecessor_level:Level.t ->\n predecessor_round:Round.t ->\n grandparent_round:Round.t ->\n validation_state\n\n(** Similar to [begin_partial_construction] but do not require\n predecessor information that is essential to the validation of\n preendorsement and endorsement operations. As a consequence, the\n validation of these operations will always fail.\n\n This function is used by the plugin RPC [run_operation], which\n does not support consensus operations anyway. *)\nval begin_no_predecessor_info : context -> Chain_id.t -> validation_state\n\n(** Check the validity of the given operation and return the updated\n {!validation_state}.\n\n See the documentation at the top of this module on operation validation.\n\n @param check_signature indicates whether the signature check\n should happen. It defaults to [true] because the signature needs to\n be correct for the operation to be valid. This argument exists for\n special cases where it is acceptable to bypass this check, e.g.:\n\n - A mempool implementation may keep track of operations whose\n signatures have already been checked: if such an operation needs to\n be validated again (typically when the head block changes), then\n the mempool may call [validate_operation] with\n [check_signature:false].\n\n - The [run_operation] RPC provided by the plugin explicitly\n excludes signature checks: see its documentation in\n [lib_plugin/RPC.Scripts.S.run_operation]. *)\nval validate_operation :\n ?check_signature:bool ->\n validation_state ->\n Operation_hash.t ->\n packed_operation ->\n validation_state tzresult Lwt.t\n\n(** Finish the validation of a block.\n\n This function should only be used after {!validate_operation} has\n been called on every operation in the block. It checks the\n consistency of the block_header with the information computed while\n validating the block's operations (Endorsement power, payload hash,\n etc.) Checks vary depending on the mode (ie. which of the\n [begin_...] functions above was used to initialize the\n [validation_state]). *)\nval finalize_block : validation_state -> unit tzresult Lwt.t\n\n(** The remaining functions are intended for the mempool.\n See {!Mempool_validation}. *)\n\n(** Check the operation validity, similarly to {!validate_operation}.\n\n However, this function does not check for conflicts with\n previously validated operations, nor global block properties such\n as the respect of the block gas limit. This allows the function to\n only take an {!info} as input rather than a full {!validation_state}.\n\n This function is intended for {!Mempool_validation} exclusively. *)\nval check_operation :\n ?check_signature:bool -> info -> 'kind operation -> unit tzresult Lwt.t\n\n(** Check that the operation does not conflict with other operations\n already validated and recorded in the {!operation_conflict_state}.\n\n This function is intended for {!Mempool_validation} exclusively. *)\nval check_operation_conflict :\n operation_conflict_state ->\n Operation_hash.t ->\n 'kind operation ->\n (unit, operation_conflict) result\n\n(** Add a valid operation to the {!operation_conflict_state}.\n\n The operation should have been previously validated by calling\n both {!check_operation} and {!check_operation_conflict}.\n\n This function is intended for {!Mempool_validation} exclusively. *)\nval add_valid_operation :\n operation_conflict_state ->\n Operation_hash.t ->\n 'kind operation ->\n operation_conflict_state\n\n(** Remove a valid operation from the {!operation_conflict_state}.\n\n Preconditions:\n - The operation has already been validated and added to the\n [operation_conflict_state].\n - The [operation_conflict_state] and other states used to validate\n the operation have been initialized by calling\n {!begin_partial_construction}.\n\n This function is intended for {!Mempool_validation}, though it is\n also called by the plugin. *)\nval remove_operation :\n operation_conflict_state -> 'kind operation -> operation_conflict_state\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Validate_errors\nopen Alpha_context\n\n(** Since the expected features of preendorsement and endorsement are\n the same for all operations in the considered block, we compute\n them once and for all at the begining of the block.\n\n See [expected_features_for_application],\n [expected_features_for_construction], and\n [expected_features_for_partial_construction] in the [Consensus]\n module below. *)\ntype expected_features = {\n level : Raw_level.t;\n round : Round.t option;\n (** This always contains a value, except for the case of\n preendorsements during block construction. See\n [Consensus.check_round_equal] below for its usage. *)\n branch : Block_hash.t;\n payload_hash : Block_payload_hash.t;\n}\n\ntype expected_preendorsement =\n | Expected_preendorsement of {\n expected_features : expected_features;\n block_round : Round.t option;\n (** During block validation or construction, we must also check that\n the preendorsement round is lower than the block round. In\n mempool mode, this field is [None]. *)\n }\n | No_locked_round_for_block_validation_preendorsement\n (** A preexisting block whose fitness indicates no locked round\n should contain no preendorsements. *)\n | Fresh_proposal_for_construction_preendorsement\n (** A constructed block with a fresh proposal should contain no\n preendorsements. *)\n | No_expected_branch_for_partial_construction_preendorsement of {\n expected_level : Raw_level.t;\n }\n (** See [No_expected_branch_for_partial_construction_endorsement] below. *)\n | No_predecessor_info_cannot_validate_preendorsement\n (** We do not have access to predecessor level, round, etc. so any\n preendorsement validation will fail. *)\n\ntype expected_endorsement =\n | Expected_endorsement of {expected_features : expected_features}\n | No_expected_branch_for_block_endorsement\n (** The context contains no branch: this happens to the first block\n that uses the Tenderbake consensus algorithm. This block contains\n no endorsements. *)\n | No_expected_branch_for_partial_construction_endorsement of {\n expected_level : Raw_level.t;\n }\n (** Same as [No_expected_branch_for_block_endorsement]. This has a\n separate constructor because the error raised is distinct: in\n mempool mode, we simply assume that we have received a\n preendorsement for a future block to which we have not switched\n yet. *)\n | No_predecessor_info_cannot_validate_endorsement\n (** We do not have access to predecessor level, round, etc. so any\n endorsement validation will fail. *)\n\ntype all_expected_consensus_features = {\n expected_preendorsement : expected_preendorsement;\n expected_endorsement : expected_endorsement;\n expected_grandparent_endorsement_for_partial_construction :\n expected_features option;\n (** This only has a value in Mempool mode and when the [ctxt] has a\n [grandparent_branch]; it is [None] in all other cases. *)\n}\n\ntype consensus_info = {\n all_expected_features : all_expected_consensus_features;\n preendorsement_slot_map : (Consensus_key.pk * int) Slot.Map.t;\n endorsement_slot_map : (Consensus_key.pk * int) Slot.Map.t;\n}\n\nlet init_consensus_info ctxt all_expected_features =\n {\n all_expected_features;\n preendorsement_slot_map = Consensus.allowed_preendorsements ctxt;\n endorsement_slot_map = Consensus.allowed_endorsements ctxt;\n }\n\nmodule Consensus_content_map = Map.Make (struct\n type t = consensus_content\n\n let compare {slot; level; round; block_payload_hash}\n {\n slot = slot';\n level = level';\n round = round';\n block_payload_hash = block_payload_hash';\n } =\n Compare.or_else (Raw_level.compare level level') @@ fun () ->\n Compare.or_else (Slot.compare slot slot') @@ fun () ->\n Compare.or_else (Round.compare round round') @@ fun () ->\n Compare.or_else\n (Block_payload_hash.compare block_payload_hash block_payload_hash')\n @@ fun () -> 0\nend)\n\ntype consensus_state = {\n predecessor_level : Raw_level.t;\n preendorsements_seen : Operation_hash.t Slot.Map.t;\n endorsements_seen : Operation_hash.t Slot.Map.t;\n grandparent_endorsements_seen : Operation_hash.t Slot.Map.t;\n dal_attestation_seen : Operation_hash.t Signature.Public_key_hash.Map.t;\n}\n\nlet slot_map_encoding element_encoding =\n let open Data_encoding in\n conv\n (fun slot_map -> Slot.Map.bindings slot_map)\n (fun l -> Slot.Map.(List.fold_left (fun m (k, v) -> add k v m) empty l))\n (list (tup2 Slot.encoding element_encoding))\n\nlet consensus_state_encoding =\n let open Data_encoding in\n def \"consensus_state\"\n @@ conv\n (fun {\n predecessor_level;\n preendorsements_seen;\n endorsements_seen;\n grandparent_endorsements_seen;\n dal_attestation_seen;\n } ->\n ( predecessor_level,\n preendorsements_seen,\n endorsements_seen,\n grandparent_endorsements_seen,\n dal_attestation_seen ))\n (fun ( predecessor_level,\n preendorsements_seen,\n endorsements_seen,\n grandparent_endorsements_seen,\n dal_attestation_seen ) ->\n {\n predecessor_level;\n preendorsements_seen;\n endorsements_seen;\n grandparent_endorsements_seen;\n dal_attestation_seen;\n })\n (obj5\n (req \"predecessor_level\" Raw_level.encoding)\n (req\n \"preendorsements_seen\"\n (slot_map_encoding Operation_hash.encoding))\n (req \"endorsements_seen\" (slot_map_encoding Operation_hash.encoding))\n (req\n \"grandparent_endorsements_seen\"\n (slot_map_encoding Operation_hash.encoding))\n (req\n \"dal_attestation_seen\"\n (Signature.Public_key_hash.Map.encoding Operation_hash.encoding)))\n\nlet init_consensus_state ~predecessor_level =\n {\n predecessor_level;\n preendorsements_seen = Slot.Map.empty;\n endorsements_seen = Slot.Map.empty;\n grandparent_endorsements_seen = Slot.Map.empty;\n dal_attestation_seen = Signature.Public_key_hash.Map.empty;\n }\n\ntype voting_state = {\n proposals_seen : Operation_hash.t Signature.Public_key_hash.Map.t;\n (** To each delegate that has submitted a Proposals operation in a\n previously validated operation, associates the hash of this\n operation. This includes Proposals from a potential Testnet\n Dictator. *)\n ballots_seen : Operation_hash.t Signature.Public_key_hash.Map.t;\n (** To each delegate that has submitted a ballot in a previously\n validated operation, associates the hash of this operation. *)\n}\n\nlet voting_state_encoding =\n let open Data_encoding in\n def \"voting_state\"\n @@ conv\n (fun {proposals_seen; ballots_seen} -> (proposals_seen, ballots_seen))\n (fun (proposals_seen, ballots_seen) -> {proposals_seen; ballots_seen})\n (obj2\n (req\n \"proposals_seen\"\n (Signature.Public_key_hash.Map.encoding Operation_hash.encoding))\n (req\n \"ballots_seen\"\n (Signature.Public_key_hash.Map.encoding Operation_hash.encoding)))\n\nmodule Double_baking_evidence_map = struct\n include Map.Make (struct\n type t = Raw_level.t * Round.t\n\n let compare (l, r) (l', r') =\n Compare.or_else (Raw_level.compare l l') @@ fun () ->\n Compare.or_else (Round.compare r r') @@ fun () -> 0\n end)\n\n let encoding elt_encoding =\n Data_encoding.conv\n (fun map -> bindings map)\n (fun l -> List.fold_left (fun m (k, v) -> add k v m) empty l)\n Data_encoding.(\n list (tup2 (tup2 Raw_level.encoding Round.encoding) elt_encoding))\nend\n\nmodule Double_endorsing_evidence_map = struct\n include Map.Make (struct\n type t = Raw_level.t * Round.t * Slot.t\n\n let compare (l, r, s) (l', r', s') =\n Compare.or_else (Raw_level.compare l l') @@ fun () ->\n Compare.or_else (Round.compare r r') @@ fun () ->\n Compare.or_else (Slot.compare s s') @@ fun () -> 0\n end)\n\n let encoding elt_encoding =\n Data_encoding.conv\n (fun map -> bindings map)\n (fun l -> List.fold_left (fun m (k, v) -> add k v m) empty l)\n Data_encoding.(\n list\n (tup2\n (tup3 Raw_level.encoding Round.encoding Slot.encoding)\n elt_encoding))\nend\n\n(** State used and modified when validating anonymous operations.\n These fields are used to enforce that we do not validate the same\n operation multiple times.\n\n Note that as part of {!state}, these maps live\n in memory. They are not explicitly bounded here, however:\n\n - In block validation mode, they are bounded by the number of\n anonymous operations allowed in the block.\n\n - In mempool mode, bounding the number of operations in this map\n is the responsability of the prevalidator on the shell side. *)\ntype anonymous_state = {\n activation_pkhs_seen : Operation_hash.t Ed25519.Public_key_hash.Map.t;\n double_baking_evidences_seen : Operation_hash.t Double_baking_evidence_map.t;\n double_endorsing_evidences_seen :\n Operation_hash.t Double_endorsing_evidence_map.t;\n seed_nonce_levels_seen : Operation_hash.t Raw_level.Map.t;\n vdf_solution_seen : Operation_hash.t option;\n}\n\nlet raw_level_map_encoding elt_encoding =\n let open Data_encoding in\n conv\n (fun map -> Raw_level.Map.bindings map)\n (fun l ->\n Raw_level.Map.(List.fold_left (fun m (k, v) -> add k v m) empty l))\n (list (tup2 Raw_level.encoding elt_encoding))\n\nlet anonymous_state_encoding =\n let open Data_encoding in\n def \"anonymous_state\"\n @@ conv\n (fun {\n activation_pkhs_seen;\n double_baking_evidences_seen;\n double_endorsing_evidences_seen;\n seed_nonce_levels_seen;\n vdf_solution_seen;\n } ->\n ( activation_pkhs_seen,\n double_baking_evidences_seen,\n double_endorsing_evidences_seen,\n seed_nonce_levels_seen,\n vdf_solution_seen ))\n (fun ( activation_pkhs_seen,\n double_baking_evidences_seen,\n double_endorsing_evidences_seen,\n seed_nonce_levels_seen,\n vdf_solution_seen ) ->\n {\n activation_pkhs_seen;\n double_baking_evidences_seen;\n double_endorsing_evidences_seen;\n seed_nonce_levels_seen;\n vdf_solution_seen;\n })\n (obj5\n (req\n \"activation_pkhs_seen\"\n (Ed25519.Public_key_hash.Map.encoding Operation_hash.encoding))\n (req\n \"double_baking_evidences_seen\"\n (Double_baking_evidence_map.encoding Operation_hash.encoding))\n (req\n \"double_endorsing_evidences_seen\"\n (Double_endorsing_evidence_map.encoding Operation_hash.encoding))\n (req\n \"seed_nonce_levels_seen\"\n (raw_level_map_encoding Operation_hash.encoding))\n (opt \"vdf_solution_seen\" Operation_hash.encoding))\n\nlet empty_anonymous_state =\n {\n activation_pkhs_seen = Ed25519.Public_key_hash.Map.empty;\n double_baking_evidences_seen = Double_baking_evidence_map.empty;\n double_endorsing_evidences_seen = Double_endorsing_evidence_map.empty;\n seed_nonce_levels_seen = Raw_level.Map.empty;\n vdf_solution_seen = None;\n }\n\n(** Static information used to validate manager operations. *)\ntype manager_info = {\n hard_storage_limit_per_operation : Z.t;\n hard_gas_limit_per_operation : Gas.Arith.integral;\n}\n\nlet init_manager_info ctxt =\n {\n hard_storage_limit_per_operation =\n Constants.hard_storage_limit_per_operation ctxt;\n hard_gas_limit_per_operation = Constants.hard_gas_limit_per_operation ctxt;\n }\n\n(** State used and modified when validating manager operations. *)\ntype manager_state = {\n managers_seen : Operation_hash.t Signature.Public_key_hash.Map.t;\n (** To enforce the one-operation-per manager-per-block restriction\n (1M). The operation hash lets us indicate the conflicting\n operation in the {!Manager_restriction} error.\n\n Note that as part of {!state}, this map\n lives in memory. It is not explicitly bounded here, however:\n\n - In block validation mode, it is bounded by the number of\n manager operations allowed in the block.\n\n - In mempool mode, bounding the number of operations in this\n map is the responsability of the mempool. (E.g. the plugin used\n by Octez has a [max_prechecked_manager_operations] parameter to\n ensure this.) *)\n}\n\nlet manager_state_encoding =\n let open Data_encoding in\n def \"manager_state\"\n @@ conv\n (fun {managers_seen} -> managers_seen)\n (fun managers_seen -> {managers_seen})\n (obj1\n (req\n \"managers_seen\"\n (Signature.Public_key_hash.Map.encoding Operation_hash.encoding)))\n\nlet empty_manager_state = {managers_seen = Signature.Public_key_hash.Map.empty}\n\n(** Mode-dependent information needed in final checks. *)\ntype block_finalization_info = {\n fitness : Fitness.t;\n block_producer : Consensus_key.pk;\n payload_producer : Consensus_key.pk;\n predecessor_hash : Block_hash.t;\n block_data_contents : Block_header.contents;\n}\n\n(** Circumstances in which operations are validated, and corresponding\n information.\n\n - [Application] is used for the validation of a preexisting block,\n often in preparation for its future application.\n\n - [Partial_validation] is used to quickly but partially validate a\n preexisting block, e.g. to quickly decide whether an alternate\n branch seems viable. In this mode, the initial {!type:context} may\n come from an ancestor block instead of the predecessor block. Only\n consensus operations are validated in this mode.\n\n - [Construction] is used for the construction of a new block.\n\n - [Mempool] is used by the {!module:Mempool} and by the\n [Partial_construction] mode in {!module:Main}, which may itself be\n used by RPCs or by another mempool implementation. (The [Mempool]\n mode is also used by the plugin.)\n\n If you add a new mode, please make sure that it has a way to bound\n the size of the map {!recfield:manager_state.managers_seen}. *)\ntype mode =\n | Application of block_finalization_info\n | Partial_validation of block_finalization_info\n | Construction of {\n predecessor_round : Round.t;\n predecessor_hash : Block_hash.t;\n round : Round.t;\n block_data_contents : Block_header.contents;\n block_producer : Consensus_key.pk;\n payload_producer : Consensus_key.pk;\n }\n | Mempool\n\n(** {2 Definition and initialization of [info] and [state]} *)\n\ntype info = {\n ctxt : t; (** The context at the beginning of the block or mempool. *)\n mode : mode;\n chain_id : Chain_id.t; (** Needed for signature checks. *)\n current_level : Level.t;\n consensus_info : consensus_info;\n manager_info : manager_info;\n}\n\ntype operation_conflict_state = {\n consensus_state : consensus_state;\n voting_state : voting_state;\n anonymous_state : anonymous_state;\n manager_state : manager_state;\n}\n\nlet operation_conflict_state_encoding =\n let open Data_encoding in\n def \"operation_conflict_state\"\n @@ conv\n (fun {consensus_state; voting_state; anonymous_state; manager_state} ->\n (consensus_state, voting_state, anonymous_state, manager_state))\n (fun (consensus_state, voting_state, anonymous_state, manager_state) ->\n {consensus_state; voting_state; anonymous_state; manager_state})\n (obj4\n (req \"consensus_state\" consensus_state_encoding)\n (req \"voting_state\" voting_state_encoding)\n (req \"anonymous_state\" anonymous_state_encoding)\n (req \"manager_state\" manager_state_encoding))\n\ntype block_state = {\n op_count : int;\n remaining_block_gas : Gas.Arith.fp;\n recorded_operations_rev : Operation_hash.t list;\n last_op_validation_pass : int option;\n locked_round_evidence : (Round.t * int) option;\n endorsement_power : int;\n}\n\ntype validation_state = {\n info : info;\n operation_state : operation_conflict_state;\n block_state : block_state;\n}\n\nlet ok_unit = Result_syntax.return_unit\n\nlet init_info ctxt mode chain_id all_expected_consensus_characteristics =\n {\n ctxt;\n mode;\n chain_id;\n current_level = Level.current ctxt;\n consensus_info =\n init_consensus_info ctxt all_expected_consensus_characteristics;\n manager_info = init_manager_info ctxt;\n }\n\nlet empty_voting_state =\n {\n proposals_seen = Signature.Public_key_hash.Map.empty;\n ballots_seen = Signature.Public_key_hash.Map.empty;\n }\n\nlet init_operation_conflict_state ~predecessor_level =\n {\n consensus_state = init_consensus_state ~predecessor_level;\n voting_state = empty_voting_state;\n anonymous_state = empty_anonymous_state;\n manager_state = empty_manager_state;\n }\n\nlet init_block_state vi =\n {\n op_count = 0;\n remaining_block_gas =\n Gas.Arith.fp (Constants.hard_gas_limit_per_block vi.ctxt);\n recorded_operations_rev = [];\n last_op_validation_pass = None;\n locked_round_evidence = None;\n endorsement_power = 0;\n }\n\nlet get_initial_ctxt {info; _} = info.ctxt\n\n(** Validation of consensus operations (validation pass [0]):\n preendorsement, endorsement, and dal_attestation. *)\nmodule Consensus = struct\n let expected_endorsement_features ~predecessor_level ~predecessor_round branch\n payload_hash =\n {\n level = predecessor_level.Level.level;\n round = Some predecessor_round;\n branch;\n payload_hash;\n }\n\n (** Expected endorsement features for all modes in which a block is\n considered: application, partial validation, and construction. *)\n let expected_endorsement_for_block ctxt ~predecessor_level ~predecessor_round\n : expected_endorsement =\n match Consensus.endorsement_branch ctxt with\n | None -> No_expected_branch_for_block_endorsement\n | Some (branch, payload_hash) ->\n let expected_features =\n expected_endorsement_features\n ~predecessor_level\n ~predecessor_round\n branch\n payload_hash\n in\n Expected_endorsement {expected_features}\n\n (** Retrieve the expected consensus features for both application and\n partial validation modes. *)\n let expected_features_for_application ctxt fitness payload_hash\n ~predecessor_level ~predecessor_round ~predecessor_hash =\n let expected_preendorsement =\n match Fitness.locked_round fitness with\n | None -> No_locked_round_for_block_validation_preendorsement\n | Some locked_round ->\n let expected_features =\n {\n level = (Level.current ctxt).level;\n round = Some locked_round;\n branch = predecessor_hash;\n payload_hash;\n }\n in\n let block_round = Some (Fitness.round fitness) in\n Expected_preendorsement {expected_features; block_round}\n in\n let expected_endorsement =\n expected_endorsement_for_block ctxt ~predecessor_level ~predecessor_round\n in\n {\n expected_preendorsement;\n expected_endorsement;\n expected_grandparent_endorsement_for_partial_construction = None;\n }\n\n let expected_features_for_construction ctxt round payload_hash\n ~predecessor_level ~predecessor_round ~predecessor_hash =\n let expected_preendorsement =\n if Block_payload_hash.(payload_hash = zero) then\n (* When the proposal is fresh, a fake [payload_hash] of [zero]\n has been provided. In this case, the block should not\n contain any preendorsements. *)\n Fresh_proposal_for_construction_preendorsement\n else\n let expected_features =\n {\n level = (Level.current ctxt).level;\n round = None;\n branch = predecessor_hash;\n payload_hash;\n }\n in\n Expected_preendorsement {expected_features; block_round = Some round}\n in\n let expected_endorsement =\n expected_endorsement_for_block ctxt ~predecessor_level ~predecessor_round\n in\n {\n expected_preendorsement;\n expected_endorsement;\n expected_grandparent_endorsement_for_partial_construction = None;\n }\n\n let expected_features_for_partial_construction ctxt ~predecessor_level\n ~predecessor_round ~grandparent_round =\n let expected_preendorsement, expected_endorsement =\n match Consensus.endorsement_branch ctxt with\n | None ->\n let expected_level = predecessor_level.Level.level in\n ( No_expected_branch_for_partial_construction_preendorsement\n {expected_level},\n No_expected_branch_for_partial_construction_endorsement\n {expected_level} )\n | Some (branch, payload_hash) ->\n let expected_features =\n expected_endorsement_features\n ~predecessor_level\n ~predecessor_round\n branch\n payload_hash\n in\n ( Expected_preendorsement {expected_features; block_round = None},\n Expected_endorsement {expected_features} )\n in\n let expected_grandparent_endorsement_for_partial_construction =\n match\n ( Consensus.grand_parent_branch ctxt,\n Raw_level.pred predecessor_level.level )\n with\n | None, _ | _, None -> None\n | Some (branch, payload_hash), Some level ->\n Some {level; round = Some grandparent_round; branch; payload_hash}\n in\n {\n expected_preendorsement;\n expected_endorsement;\n expected_grandparent_endorsement_for_partial_construction;\n }\n\n open Validate_errors.Consensus\n\n let check_frozen_deposits_are_positive ctxt delegate_pkh =\n let open Lwt_result_syntax in\n let* frozen_deposits = Delegate.frozen_deposits ctxt delegate_pkh in\n fail_unless\n Tez.(frozen_deposits.current_amount > zero)\n (Zero_frozen_deposits delegate_pkh)\n\n let check_level_equal kind expected_features\n (consensus_content : consensus_content) =\n let expected = expected_features.level in\n let provided = consensus_content.level in\n error_unless\n (Raw_level.equal expected provided)\n (if Raw_level.(expected > provided) then\n Consensus_operation_for_old_level {kind; expected; provided}\n else Consensus_operation_for_future_level {kind; expected; provided})\n\n let check_round kind expected (consensus_content : consensus_content) =\n let provided = consensus_content.round in\n error_unless\n (Round.equal expected provided)\n (if Round.(expected > provided) then\n Consensus_operation_for_old_round {kind; expected; provided}\n else Consensus_operation_for_future_round {kind; expected; provided})\n\n let check_round_equal kind expected_features\n (consensus_content : consensus_content) =\n match expected_features.round with\n | Some expected -> check_round kind expected consensus_content\n | None -> ok_unit\n\n let check_branch_equal kind expected_features (operation : 'a operation) =\n let expected = expected_features.branch in\n let provided = operation.shell.branch in\n error_unless\n (Block_hash.equal expected provided)\n (Wrong_consensus_operation_branch {kind; expected; provided})\n\n let check_payload_hash_equal kind expected_features\n (consensus_content : consensus_content) =\n let expected = expected_features.payload_hash in\n let provided = consensus_content.block_payload_hash in\n error_unless\n (Block_payload_hash.equal expected provided)\n (Wrong_payload_hash_for_consensus_operation {kind; expected; provided})\n\n let check_consensus_features kind (expected : expected_features)\n (consensus_content : consensus_content) (operation : 'a operation) =\n let open Result_syntax in\n let* () = check_level_equal kind expected consensus_content in\n let* () = check_round_equal kind expected consensus_content in\n let* () = check_branch_equal kind expected operation in\n check_payload_hash_equal kind expected consensus_content\n\n let get_expected_preendorsements_features consensus_info consensus_content =\n match consensus_info.all_expected_features.expected_preendorsement with\n | Expected_preendorsement {expected_features; block_round} ->\n ok (expected_features, block_round)\n | No_locked_round_for_block_validation_preendorsement\n | Fresh_proposal_for_construction_preendorsement ->\n error Unexpected_preendorsement_in_block\n | No_expected_branch_for_partial_construction_preendorsement\n {expected_level} ->\n error\n (Consensus_operation_for_future_level\n {\n kind = Preendorsement;\n expected = expected_level;\n provided = consensus_content.Alpha_context.level;\n })\n | No_predecessor_info_cannot_validate_preendorsement ->\n error Consensus_operation_not_allowed\n\n let check_round_not_too_high ~block_round ~provided =\n match block_round with\n | None -> ok_unit\n | Some block_round ->\n error_unless\n Round.(provided < block_round)\n (Preendorsement_round_too_high {block_round; provided})\n\n let get_delegate_details slot_map kind consensus_content =\n Result.of_option\n (Slot.Map.find consensus_content.slot slot_map)\n ~error:(trace_of_error (Wrong_slot_used_for_consensus_operation {kind}))\n\n let check_preendorsement vi ~check_signature\n (operation : Kind.preendorsement operation) =\n let open Lwt_result_syntax in\n let (Single (Preendorsement consensus_content)) =\n operation.protocol_data.contents\n in\n let kind = Preendorsement in\n let*? expected_features, block_round =\n get_expected_preendorsements_features vi.consensus_info consensus_content\n in\n let*? () =\n check_round_not_too_high ~block_round ~provided:consensus_content.round\n in\n let*? () =\n check_consensus_features\n kind\n expected_features\n consensus_content\n operation\n in\n let*? consensus_key, voting_power =\n get_delegate_details\n vi.consensus_info.preendorsement_slot_map\n kind\n consensus_content\n in\n let* () =\n check_frozen_deposits_are_positive vi.ctxt consensus_key.delegate\n in\n let*? () =\n if check_signature then\n Operation.check_signature\n consensus_key.consensus_pk\n vi.chain_id\n operation\n else ok_unit\n in\n return voting_power\n\n let check_preendorsement_conflict vs oph (op : Kind.preendorsement operation)\n =\n let (Single (Preendorsement consensus_content)) =\n op.protocol_data.contents\n in\n match\n Slot.Map.find_opt\n consensus_content.slot\n vs.consensus_state.preendorsements_seen\n with\n | Some existing ->\n Error (Operation_conflict {existing; new_operation = oph})\n | None -> ok_unit\n\n let wrap_preendorsement_conflict = function\n | Ok () -> ok_unit\n | Error conflict ->\n error\n Validate_errors.Consensus.(\n Conflicting_consensus_operation {kind = Preendorsement; conflict})\n\n let add_preendorsement vs oph (op : Kind.preendorsement operation) =\n let (Single (Preendorsement consensus_content)) =\n op.protocol_data.contents\n in\n let preendorsements_seen =\n Slot.Map.add\n consensus_content.slot\n oph\n vs.consensus_state.preendorsements_seen\n in\n {vs with consensus_state = {vs.consensus_state with preendorsements_seen}}\n\n let may_update_locked_round_evidence block_state mode\n (consensus_content : consensus_content) voting_power =\n let locked_round_evidence =\n match mode with\n | Mempool -> None\n | Application _ | Partial_validation _ | Construction _ -> (\n match block_state.locked_round_evidence with\n | None -> Some (consensus_content.round, voting_power)\n | Some (_stored_round, evidences) ->\n (* [_stored_round] is always equal to [consensus_content.round].\n Indeed, this is ensured by {!check_round_equal} in\n application and partial validation modes, and by\n {!check_construction_preendorsement_round_consistency} in\n construction mode. *)\n Some (consensus_content.round, evidences + voting_power))\n in\n {block_state with locked_round_evidence}\n\n (* Hypothesis: this function will only be called in mempool mode *)\n let remove_preendorsement vs (operation : Kind.preendorsement operation) =\n (* As we are in mempool mode, we do not update\n [locked_round_evidence]. *)\n let (Single (Preendorsement consensus_content)) =\n operation.protocol_data.contents\n in\n let preendorsements_seen =\n Slot.Map.remove\n consensus_content.slot\n vs.consensus_state.preendorsements_seen\n in\n {vs with consensus_state = {vs.consensus_state with preendorsements_seen}}\n\n (** Validate an endorsement pointing to the grandparent block. This\n function will only be called in [Partial_construction] mode. *)\n let check_grandparent_endorsement vi ~check_signature expected operation\n (consensus_content : consensus_content) =\n let open Lwt_result_syntax in\n let kind = Grandparent_endorsement in\n let level = Level.from_raw vi.ctxt consensus_content.level in\n let* (_ctxt : t), consensus_key =\n Stake_distribution.slot_owner vi.ctxt level consensus_content.slot\n in\n let*? () =\n check_consensus_features kind expected consensus_content operation\n in\n let*? () =\n if check_signature then\n Operation.check_signature\n consensus_key.consensus_pk\n vi.chain_id\n operation\n else ok_unit\n in\n return_unit\n\n let add_grandparent_endorsement vs oph (consensus_content : consensus_content)\n =\n {\n vs with\n consensus_state =\n {\n vs.consensus_state with\n grandparent_endorsements_seen =\n Slot.Map.add\n consensus_content.slot\n oph\n vs.consensus_state.grandparent_endorsements_seen;\n };\n }\n\n let check_grandparent_endorsement_conflict vs oph\n (consensus_content : consensus_content) =\n match\n Slot.Map.find_opt\n consensus_content.slot\n vs.consensus_state.grandparent_endorsements_seen\n with\n | None -> ok_unit\n | Some existing ->\n Error (Operation_conflict {existing; new_operation = oph})\n\n let remove_grandparent_endorsement vs (consensus_content : consensus_content)\n =\n let grandparent_endorsements_seen =\n Slot.Map.remove\n consensus_content.slot\n vs.consensus_state.grandparent_endorsements_seen\n in\n {\n vs with\n consensus_state = {vs.consensus_state with grandparent_endorsements_seen};\n }\n\n let get_expected_endorsements_features consensus_info consensus_content =\n match consensus_info.all_expected_features.expected_endorsement with\n | Expected_endorsement {expected_features} -> ok expected_features\n | No_expected_branch_for_block_endorsement ->\n error Unexpected_endorsement_in_block\n | No_expected_branch_for_partial_construction_endorsement {expected_level}\n ->\n error\n (Consensus_operation_for_future_level\n {\n kind = Endorsement;\n expected = expected_level;\n provided = consensus_content.Alpha_context.level;\n })\n | No_predecessor_info_cannot_validate_endorsement ->\n error Consensus_operation_not_allowed\n\n type endorsement_kind = Grandparent_endorsement | Normal_endorsement of int\n\n (** Validate an endorsement pointing to the predecessor, aka a\n \"normal\" endorsement. Only this kind of endorsement may be found\n during block validation or construction. *)\n let check_normal_endorsement vi ~check_signature\n (operation : Kind.endorsement operation) =\n let open Lwt_result_syntax in\n let (Single (Endorsement consensus_content)) =\n operation.protocol_data.contents\n in\n let kind = Endorsement in\n let*? expected_features =\n get_expected_endorsements_features vi.consensus_info consensus_content\n in\n let*? () =\n check_consensus_features\n kind\n expected_features\n consensus_content\n operation\n in\n let*? consensus_key, voting_power =\n get_delegate_details\n vi.consensus_info.endorsement_slot_map\n kind\n consensus_content\n in\n let* () =\n check_frozen_deposits_are_positive vi.ctxt consensus_key.delegate\n in\n let*? () =\n if check_signature then\n Operation.check_signature\n consensus_key.consensus_pk\n vi.chain_id\n operation\n else ok_unit\n in\n return voting_power\n\n let check_normal_endorsement_conflict vs oph\n (consensus_content : consensus_content) =\n match\n Slot.Map.find_opt\n consensus_content.slot\n vs.consensus_state.endorsements_seen\n with\n | None -> ok_unit\n | Some existing ->\n Error (Operation_conflict {existing; new_operation = oph})\n\n let add_normal_endorsement vs oph (consensus_content : consensus_content) =\n {\n vs with\n consensus_state =\n {\n vs.consensus_state with\n endorsements_seen =\n Slot.Map.add\n consensus_content.slot\n oph\n vs.consensus_state.endorsements_seen;\n };\n }\n\n (* Hypothesis: this function will only be called in mempool mode *)\n let remove_normal_endorsement vs (consensus_content : consensus_content) =\n (* We do not remove the endorsement power because it is not\n relevant for the mempool mode. *)\n let endorsements_seen =\n Slot.Map.remove\n consensus_content.slot\n vs.consensus_state.endorsements_seen\n in\n {vs with consensus_state = {vs.consensus_state with endorsements_seen}}\n\n let check_endorsement vi ~check_signature\n (operation : Kind.endorsement operation) =\n let open Lwt_result_syntax in\n let (Single (Endorsement consensus_content)) =\n operation.protocol_data.contents\n in\n match\n vi.consensus_info.all_expected_features\n .expected_grandparent_endorsement_for_partial_construction\n with\n | Some expected_grandparent_endorsement\n when Raw_level.(\n consensus_content.level = expected_grandparent_endorsement.level)\n ->\n let* () =\n check_grandparent_endorsement\n vi\n ~check_signature\n expected_grandparent_endorsement\n operation\n (consensus_content : consensus_content)\n in\n return Grandparent_endorsement\n | _ ->\n let* voting_power =\n check_normal_endorsement vi ~check_signature operation\n in\n return (Normal_endorsement voting_power)\n\n let is_normal_endorsement_assuming_valid vs\n (consensus_content : consensus_content) =\n Raw_level.equal vs.consensus_state.predecessor_level consensus_content.level\n\n let check_endorsement_conflict vs oph (operation : Kind.endorsement operation)\n =\n let (Single (Endorsement consensus_content)) =\n operation.protocol_data.contents\n in\n if is_normal_endorsement_assuming_valid vs consensus_content then\n check_normal_endorsement_conflict vs oph consensus_content\n else check_grandparent_endorsement_conflict vs oph consensus_content\n\n let wrap_endorsement_conflict = function\n | Ok () -> ok_unit\n | Error conflict ->\n error\n Validate_errors.Consensus.(\n Conflicting_consensus_operation {kind = Endorsement; conflict})\n\n let add_endorsement vs oph (op : Kind.endorsement operation) endorsement_kind\n =\n let (Single (Endorsement consensus_content)) = op.protocol_data.contents in\n match endorsement_kind with\n | Grandparent_endorsement ->\n add_grandparent_endorsement vs oph consensus_content\n | Normal_endorsement _voting_power ->\n add_normal_endorsement vs oph consensus_content\n\n let may_update_endorsement_power block_state = function\n | Grandparent_endorsement -> block_state\n | Normal_endorsement voting_power ->\n {\n block_state with\n endorsement_power = block_state.endorsement_power + voting_power;\n }\n\n let remove_endorsement vs (op : Kind.endorsement operation) =\n let (Single (Endorsement consensus_content)) = op.protocol_data.contents in\n if is_normal_endorsement_assuming_valid vs consensus_content then\n remove_normal_endorsement vs consensus_content\n else remove_grandparent_endorsement vs consensus_content\n\n let check_dal_attestation vi (operation : Kind.dal_attestation operation) =\n (* DAL/FIXME https://gitlab.com/tezos/tezos/-/issues/3115\n This is a temporary operation. Some checks are missing for the\n moment. In particular, the signature is not\n checked. Consequently, it is really important to ensure this\n operation cannot be included into a block when the feature flag\n is not set. This is done in order to avoid modifying the\n endorsement encoding. However, once the DAL is ready, this\n operation should be merged with an endorsement or at least\n refined. *)\n let open Lwt_result_syntax in\n let (Single (Dal_attestation op)) = operation.protocol_data.contents in\n let*? () =\n (* Note that this function checks the dal feature flag. *)\n Dal_apply.validate_attestation vi.ctxt op\n in\n return_unit\n\n let check_dal_attestation_conflict vs oph\n (operation : Kind.dal_attestation operation) =\n let (Single (Dal_attestation {attestor; attestation = _; level = _})) =\n operation.protocol_data.contents\n in\n match\n Signature.Public_key_hash.Map.find_opt\n attestor\n vs.consensus_state.dal_attestation_seen\n with\n | None -> ok_unit\n | Some existing ->\n Error (Operation_conflict {existing; new_operation = oph})\n\n let wrap_dal_attestation_conflict = function\n | Ok () -> ok_unit\n | Error conflict ->\n error\n Validate_errors.Consensus.(\n Conflicting_consensus_operation {kind = Dal_attestation; conflict})\n\n let add_dal_attestation vs oph (operation : Kind.dal_attestation operation) =\n let (Single (Dal_attestation {attestor; attestation = _; level = _})) =\n operation.protocol_data.contents\n in\n {\n vs with\n consensus_state =\n {\n vs.consensus_state with\n dal_attestation_seen =\n Signature.Public_key_hash.Map.add\n attestor\n oph\n vs.consensus_state.dal_attestation_seen;\n };\n }\n\n let remove_dal_attestation vs (operation : Kind.dal_attestation operation) =\n let (Single (Dal_attestation {attestor; attestation = _; level = _})) =\n operation.protocol_data.contents\n in\n let dal_attestation_seen =\n Signature.Public_key_hash.Map.remove\n attestor\n vs.consensus_state.dal_attestation_seen\n in\n {vs with consensus_state = {vs.consensus_state with dal_attestation_seen}}\n\n let check_construction_preendorsement_round_consistency vi block_state kind\n (consensus_content : consensus_content) =\n let open Result_syntax in\n let* expected_features, _block_round =\n get_expected_preendorsements_features vi.consensus_info consensus_content\n in\n match expected_features.round with\n | Some _ ->\n (* When [expected_features.round] has a value (ie. in\n application and partial validation modes when the block\n fitness has a [locked_round], and always in mempool mode),\n [check_preendorsement] already checks that all\n preendorsements have this expected round, so checking\n anything here would be redundant. Also note that when the\n fitness contains no [locked_round], this code is\n unreachable because [get_expected_preendorsements_features]\n returns an error. *)\n return_unit\n | None -> (\n (* For preendorsements in block construction mode,\n [expected_features.round] has been set to [None] because we\n could not know yet whether there is a locked round. *)\n match block_state.locked_round_evidence with\n | None ->\n (* This is the first validated preendorsement in\n construction mode: there is nothing to check. *)\n return_unit\n | Some (expected, _power) ->\n (* Other preendorsements have already been validated: we\n check that the current operation has the same round as\n them. *)\n check_round kind expected consensus_content)\n\n let validate_preendorsement ~check_signature info operation_state block_state\n oph (operation : Kind.preendorsement operation) =\n let open Lwt_result_syntax in\n let (Single (Preendorsement consensus_content)) =\n operation.protocol_data.contents\n in\n let* voting_power = check_preendorsement info ~check_signature operation in\n let*? () =\n check_construction_preendorsement_round_consistency\n info\n block_state\n Preendorsement\n consensus_content\n in\n let*? () =\n check_preendorsement_conflict operation_state oph operation\n |> wrap_preendorsement_conflict\n in\n (* We need to update the block state *)\n let block_state =\n may_update_locked_round_evidence\n block_state\n info.mode\n consensus_content\n voting_power\n in\n let operation_state = add_preendorsement operation_state oph operation in\n return {info; operation_state; block_state}\n\n let validate_endorsement ~check_signature info operation_state block_state oph\n operation =\n let open Lwt_result_syntax in\n let* kind = check_endorsement info ~check_signature operation in\n let*? () =\n check_endorsement_conflict operation_state oph operation\n |> wrap_endorsement_conflict\n in\n let block_state = may_update_endorsement_power block_state kind in\n let operation_state = add_endorsement operation_state oph operation kind in\n return {info; operation_state; block_state}\nend\n\n(** {2 Validation of voting operations}\n\n There are two kinds of voting operations:\n\n - Proposals: A delegate submits a list of protocol amendment\n proposals. This operation is only accepted during a Proposal period\n (see above).\n\n - Ballot: A delegate casts a vote for/against the current proposal\n (or pass). This operation is only accepted during an Exploration\n or Promotion period (see above). *)\n\nmodule Voting = struct\n open Validate_errors.Voting\n\n let check_period_index ~expected period_index =\n error_unless\n Compare.Int32.(expected = period_index)\n (Wrong_voting_period_index {expected; provided = period_index})\n\n let check_proposals_source_is_registered ctxt source =\n let open Lwt_result_syntax in\n let*! is_registered = Delegate.registered ctxt source in\n fail_unless is_registered (Proposals_from_unregistered_delegate source)\n\n (** Check that the list of proposals is not empty and does not contain\n duplicates. *)\n let check_proposal_list_sanity proposals =\n let open Result_syntax in\n let* () =\n match proposals with [] -> error Empty_proposals | _ :: _ -> ok_unit\n in\n let* (_ : Protocol_hash.Set.t) =\n List.fold_left_e\n (fun previous_elements proposal ->\n let* () =\n error_when\n (Protocol_hash.Set.mem proposal previous_elements)\n (Proposals_contain_duplicate {proposal})\n in\n return (Protocol_hash.Set.add proposal previous_elements))\n Protocol_hash.Set.empty\n proposals\n in\n return_unit\n\n let check_period_kind_for_proposals current_period =\n match current_period.Voting_period.kind with\n | Proposal -> ok_unit\n | (Exploration | Cooldown | Promotion | Adoption) as current ->\n error (Wrong_voting_period_kind {current; expected = [Proposal]})\n\n let check_in_listings ctxt source =\n let open Lwt_result_syntax in\n let*! in_listings = Vote.in_listings ctxt source in\n fail_unless in_listings Source_not_in_vote_listings\n\n let check_count ~count_in_ctxt ~proposals_length =\n (* The proposal count of the proposer in the context should never\n have been increased above [max_proposals_per_delegate]. *)\n assert (Compare.Int.(count_in_ctxt <= Constants.max_proposals_per_delegate)) ;\n error_unless\n Compare.Int.(\n count_in_ctxt + proposals_length <= Constants.max_proposals_per_delegate)\n (Too_many_proposals\n {previous_count = count_in_ctxt; operation_count = proposals_length})\n\n let check_already_proposed ctxt proposer proposals =\n let open Lwt_result_syntax in\n List.iter_es\n (fun proposal ->\n let*! already_proposed = Vote.has_proposed ctxt proposer proposal in\n fail_when already_proposed (Already_proposed {proposal}))\n proposals\n\n (** Check that the [apply_testnet_dictator_proposals] function in\n {!module:Amendment} will not fail.\n\n The current function is designed to be exclusively called by\n [check_proposals] right below.\n\n @return [Error Testnet_dictator_multiple_proposals] if\n [proposals] has more than one element. *)\n let check_testnet_dictator_proposals chain_id proposals =\n (* This assertion should be ensured by the fact that\n {!Amendment.is_testnet_dictator} cannot be [true] on mainnet\n (so the current function cannot be called there). However, we\n still double check it because of its criticality. *)\n assert (Chain_id.(chain_id <> Constants.mainnet_id)) ;\n match proposals with\n | [] | [_] ->\n (* In [Amendment.apply_testnet_dictator_proposals], the call to\n {!Vote.init_current_proposal} (in the singleton list case)\n cannot fail because {!Vote.clear_current_proposal} is called\n right before.\n\n The calls to\n {!Voting_period.Testnet_dictator.overwrite_current_kind} may\n usually fail when the voting period is not\n initialized. However, this cannot happen here because the\n current function is only called in [check_proposals] after a\n successful call to {!Voting_period.get_current}. *)\n ok_unit\n | _ :: _ :: _ -> error Testnet_dictator_multiple_proposals\n\n (** Check that a Proposals operation can be safely applied.\n\n @return [Error Wrong_voting_period_index] if the operation's\n period and the current period in the {!type:context} do not have\n the same index.\n\n @return [Error Proposals_from_unregistered_delegate] if the\n source is not a registered delegate.\n\n @return [Error Empty_proposals] if the list of proposals is empty.\n\n @return [Error Proposals_contain_duplicate] if the list of\n proposals contains a duplicate element.\n\n @return [Error Wrong_voting_period_kind] if the voting period is\n not of the Proposal kind.\n\n @return [Error Source_not_in_vote_listings] if the source is not\n in the vote listings.\n\n @return [Error Too_many_proposals] if the operation causes the\n source's total number of proposals during the current voting\n period to exceed {!Constants.max_proposals_per_delegate}.\n\n @return [Error Already_proposed] if one of the proposals has\n already been proposed by the source in the current voting period.\n\n @return [Error Testnet_dictator_multiple_proposals] if the\n source is a testnet dictator and the operation contains more than\n one proposal.\n\n @return [Error Operation.Missing_signature] or [Error\n Operation.Invalid_signature] if the operation is unsigned or\n incorrectly signed. *)\n let check_proposals vi ~check_signature (operation : Kind.proposals operation)\n =\n let open Lwt_result_syntax in\n let (Single (Proposals {source; period; proposals})) =\n operation.protocol_data.contents\n in\n let* current_period = Voting_period.get_current vi.ctxt in\n let*? () = check_period_index ~expected:current_period.index period in\n let* () =\n if Amendment.is_testnet_dictator vi.ctxt vi.chain_id source then\n let*? () = check_testnet_dictator_proposals vi.chain_id proposals in\n return_unit\n else\n let* () = check_proposals_source_is_registered vi.ctxt source in\n let*? () = check_proposal_list_sanity proposals in\n let*? () = check_period_kind_for_proposals current_period in\n let* () = check_in_listings vi.ctxt source in\n let* count_in_ctxt = Vote.get_delegate_proposal_count vi.ctxt source in\n let proposals_length = List.length proposals in\n let*? () = check_count ~count_in_ctxt ~proposals_length in\n check_already_proposed vi.ctxt source proposals\n in\n if check_signature then\n (* Retrieving the public key should not fail as it *should* be\n called after checking that the delegate is in the vote\n listings (or is a testnet dictator), which implies that it\n is a manager with a revealed key. *)\n let* public_key = Contract.get_manager_key vi.ctxt source in\n Lwt.return (Operation.check_signature public_key vi.chain_id operation)\n else return_unit\n\n (** Check that a Proposals operation is compatible with previously\n validated operations in the current block/mempool.\n\n @return [Error Operation_conflict] if the current block/mempool\n already contains a Proposals operation from the same source\n (regardless of whether this source is a testnet dictator or an\n ordinary manager). *)\n let check_proposals_conflict vs oph (operation : Kind.proposals operation) =\n let open Result_syntax in\n let (Single (Proposals {source; _})) = operation.protocol_data.contents in\n match\n Signature.Public_key_hash.Map.find_opt\n source\n vs.voting_state.proposals_seen\n with\n | None -> return_unit\n | Some existing ->\n Error (Operation_conflict {existing; new_operation = oph})\n\n let wrap_proposals_conflict = function\n | Ok () -> ok_unit\n | Error conflict ->\n error Validate_errors.Voting.(Conflicting_proposals conflict)\n\n let add_proposals vs oph (operation : Kind.proposals operation) =\n let (Single (Proposals {source; _})) = operation.protocol_data.contents in\n let proposals_seen =\n Signature.Public_key_hash.Map.add\n source\n oph\n vs.voting_state.proposals_seen\n in\n let voting_state = {vs.voting_state with proposals_seen} in\n {vs with voting_state}\n\n let remove_proposals vs (operation : Kind.proposals operation) =\n let (Single (Proposals {source; _})) = operation.protocol_data.contents in\n let proposals_seen =\n Signature.Public_key_hash.Map.remove source vs.voting_state.proposals_seen\n in\n {vs with voting_state = {vs.voting_state with proposals_seen}}\n\n let check_ballot_source_is_registered ctxt source =\n let open Lwt_result_syntax in\n let*! is_registered = Delegate.registered ctxt source in\n fail_unless is_registered (Ballot_from_unregistered_delegate source)\n\n let check_period_kind_for_ballot current_period =\n match current_period.Voting_period.kind with\n | Exploration | Promotion -> ok_unit\n | (Cooldown | Proposal | Adoption) as current ->\n error\n (Wrong_voting_period_kind\n {current; expected = [Exploration; Promotion]})\n\n let check_current_proposal ctxt op_proposal =\n let open Lwt_result_syntax in\n let* current_proposal = Vote.get_current_proposal ctxt in\n fail_unless\n (Protocol_hash.equal op_proposal current_proposal)\n (Ballot_for_wrong_proposal\n {current = current_proposal; submitted = op_proposal})\n\n let check_source_has_not_already_voted ctxt source =\n let open Lwt_result_syntax in\n let*! has_ballot = Vote.has_recorded_ballot ctxt source in\n fail_when has_ballot Already_submitted_a_ballot\n\n (** Check that a Ballot operation can be safely applied.\n\n @return [Error Ballot_from_unregistered_delegate] if the source\n is not a registered delegate.\n\n @return [Error Wrong_voting_period_index] if the operation's\n period and the current period in the {!type:context} do not have\n the same index.\n\n @return [Error Wrong_voting_period_kind] if the voting period is\n not of the Exploration or Promotion kind.\n\n @return [Error Ballot_for_wrong_proposal] if the operation's\n proposal is different from the current proposal in the context.\n\n @return [Error Already_submitted_a_ballot] if the source has\n already voted during the current voting period.\n\n @return [Error Source_not_in_vote_listings] if the source is not\n in the vote listings.\n\n @return [Error Operation.Missing_signature] or [Error\n Operation.Invalid_signature] if the operation is unsigned or\n incorrectly signed. *)\n let check_ballot vi ~check_signature (operation : Kind.ballot operation) =\n let open Lwt_result_syntax in\n let (Single (Ballot {source; period; proposal; ballot = _})) =\n operation.protocol_data.contents\n in\n let* () = check_ballot_source_is_registered vi.ctxt source in\n let* current_period = Voting_period.get_current vi.ctxt in\n let*? () = check_period_index ~expected:current_period.index period in\n let*? () = check_period_kind_for_ballot current_period in\n let* () = check_current_proposal vi.ctxt proposal in\n let* () = check_source_has_not_already_voted vi.ctxt source in\n let* () = check_in_listings vi.ctxt source in\n when_ check_signature (fun () ->\n (* Retrieving the public key cannot fail. Indeed, we have\n already checked that the delegate is in the vote listings,\n which implies that it is a manager with a revealed key. *)\n let* public_key = Contract.get_manager_key vi.ctxt source in\n Lwt.return (Operation.check_signature public_key vi.chain_id operation))\n\n (** Check that a Ballot operation is compatible with previously\n validated operations in the current block/mempool.\n\n @return [Error Operation_conflict] if the current block/mempool\n already contains a Ballot operation from the same source. *)\n let check_ballot_conflict vs oph (operation : Kind.ballot operation) =\n let (Single (Ballot {source; _})) = operation.protocol_data.contents in\n match\n Signature.Public_key_hash.Map.find_opt source vs.voting_state.ballots_seen\n with\n | None -> ok_unit\n | Some existing ->\n Error (Operation_conflict {existing; new_operation = oph})\n\n let wrap_ballot_conflict = function\n | Ok () -> ok_unit\n | Error conflict -> error (Conflicting_ballot conflict)\n\n let add_ballot vs oph (operation : Kind.ballot operation) =\n let (Single (Ballot {source; _})) = operation.protocol_data.contents in\n let ballots_seen =\n Signature.Public_key_hash.Map.add source oph vs.voting_state.ballots_seen\n in\n let voting_state = {vs.voting_state with ballots_seen} in\n {vs with voting_state}\n\n let remove_ballot vs (operation : Kind.ballot operation) =\n let (Single (Ballot {source; _})) = operation.protocol_data.contents in\n let ballots_seen =\n Signature.Public_key_hash.Map.remove source vs.voting_state.ballots_seen\n in\n {vs with voting_state = {vs.voting_state with ballots_seen}}\nend\n\nmodule Anonymous = struct\n open Validate_errors.Anonymous\n\n let check_activate_account vi (operation : Kind.activate_account operation) =\n let (Single (Activate_account {id = edpkh; activation_code})) =\n operation.protocol_data.contents\n in\n let open Lwt_result_syntax in\n let blinded_pkh =\n Blinded_public_key_hash.of_ed25519_pkh activation_code edpkh\n in\n let*! exists = Commitment.exists vi.ctxt blinded_pkh in\n let*? () = error_unless exists (Invalid_activation {pkh = edpkh}) in\n return_unit\n\n let check_activate_account_conflict vs oph\n (operation : Kind.activate_account operation) =\n let (Single (Activate_account {id = edpkh; _})) =\n operation.protocol_data.contents\n in\n match\n Ed25519.Public_key_hash.Map.find_opt\n edpkh\n vs.anonymous_state.activation_pkhs_seen\n with\n | None -> ok_unit\n | Some existing ->\n Error (Operation_conflict {existing; new_operation = oph})\n\n let wrap_activate_account_conflict\n (operation : Kind.activate_account operation) = function\n | Ok () -> ok_unit\n | Error conflict ->\n let (Single (Activate_account {id = edpkh; _})) =\n operation.protocol_data.contents\n in\n error (Conflicting_activation {edpkh; conflict})\n\n let add_activate_account vs oph (operation : Kind.activate_account operation)\n =\n let (Single (Activate_account {id = edpkh; _})) =\n operation.protocol_data.contents\n in\n let activation_pkhs_seen =\n Ed25519.Public_key_hash.Map.add\n edpkh\n oph\n vs.anonymous_state.activation_pkhs_seen\n in\n {vs with anonymous_state = {vs.anonymous_state with activation_pkhs_seen}}\n\n let remove_activate_account vs (operation : Kind.activate_account operation) =\n let (Single (Activate_account {id = edpkh; _})) =\n operation.protocol_data.contents\n in\n let activation_pkhs_seen =\n Ed25519.Public_key_hash.Map.remove\n edpkh\n vs.anonymous_state.activation_pkhs_seen\n in\n {vs with anonymous_state = {vs.anonymous_state with activation_pkhs_seen}}\n\n let check_denunciation_age vi kind given_level =\n let open Result_syntax in\n let current_cycle = vi.current_level.cycle in\n let given_cycle = (Level.from_raw vi.ctxt given_level).cycle in\n let max_slashing_period = Constants.max_slashing_period vi.ctxt in\n let last_slashable_cycle = Cycle.add given_cycle max_slashing_period in\n let* () =\n error_unless\n Cycle.(given_cycle <= current_cycle)\n (Too_early_denunciation\n {kind; level = given_level; current = vi.current_level.level})\n in\n error_unless\n Cycle.(last_slashable_cycle > current_cycle)\n (Outdated_denunciation\n {kind; level = given_level; last_cycle = last_slashable_cycle})\n\n let check_double_endorsing_evidence (type kind)\n ~consensus_operation:denunciation_kind vi\n (op1 : kind Kind.consensus Operation.t)\n (op2 : kind Kind.consensus Operation.t) =\n let open Lwt_result_syntax in\n match (op1.protocol_data.contents, op2.protocol_data.contents) with\n | Single (Preendorsement e1), Single (Preendorsement e2)\n | Single (Endorsement e1), Single (Endorsement e2) ->\n let op1_hash = Operation.hash op1 in\n let op2_hash = Operation.hash op2 in\n let*? () =\n error_unless\n (Raw_level.(e1.level = e2.level)\n && Round.(e1.round = e2.round)\n && (not\n (Block_payload_hash.equal\n e1.block_payload_hash\n e2.block_payload_hash))\n && (* we require an order on hashes to avoid the existence of\n equivalent evidences *)\n Operation_hash.(op1_hash < op2_hash))\n (Invalid_denunciation denunciation_kind)\n in\n (* Disambiguate: levels are equal *)\n let level = Level.from_raw vi.ctxt e1.level in\n let*? () = check_denunciation_age vi denunciation_kind level.level in\n let* ctxt, consensus_key1 =\n Stake_distribution.slot_owner vi.ctxt level e1.slot\n in\n let* ctxt, consensus_key2 =\n Stake_distribution.slot_owner ctxt level e2.slot\n in\n let delegate1, delegate2 =\n (consensus_key1.delegate, consensus_key2.delegate)\n in\n let*? () =\n error_unless\n (Signature.Public_key_hash.equal delegate1 delegate2)\n (Inconsistent_denunciation\n {kind = denunciation_kind; delegate1; delegate2})\n in\n let delegate_pk, delegate = (consensus_key1.consensus_pk, delegate1) in\n let* already_slashed =\n Delegate.already_slashed_for_double_endorsing ctxt delegate level\n in\n let*? () =\n error_unless\n (not already_slashed)\n (Already_denounced {kind = denunciation_kind; delegate; level})\n in\n let*? () = Operation.check_signature delegate_pk vi.chain_id op1 in\n let*? () = Operation.check_signature delegate_pk vi.chain_id op2 in\n return_unit\n\n let check_double_preendorsement_evidence vi\n (operation : Kind.double_preendorsement_evidence operation) =\n let (Single (Double_preendorsement_evidence {op1; op2})) =\n operation.protocol_data.contents\n in\n check_double_endorsing_evidence\n ~consensus_operation:Preendorsement\n vi\n op1\n op2\n\n let check_double_endorsement_evidence vi\n (operation : Kind.double_endorsement_evidence operation) =\n let (Single (Double_endorsement_evidence {op1; op2})) =\n operation.protocol_data.contents\n in\n check_double_endorsing_evidence ~consensus_operation:Endorsement vi op1 op2\n\n let check_double_endorsing_evidence_conflict (type kind) vs oph\n (op1 : kind Kind.consensus Operation.t) =\n match op1.protocol_data.contents with\n | Single (Preendorsement e1) | Single (Endorsement e1) -> (\n match\n Double_endorsing_evidence_map.find\n (e1.level, e1.round, e1.slot)\n vs.anonymous_state.double_endorsing_evidences_seen\n with\n | None -> ok_unit\n | Some existing ->\n Error (Operation_conflict {existing; new_operation = oph}))\n\n let check_double_preendorsement_evidence_conflict vs oph\n (operation : Kind.double_preendorsement_evidence operation) =\n let (Single (Double_preendorsement_evidence {op1; _})) =\n operation.protocol_data.contents\n in\n check_double_endorsing_evidence_conflict vs oph op1\n\n let check_double_endorsement_evidence_conflict vs oph\n (operation : Kind.double_endorsement_evidence operation) =\n let (Single (Double_endorsement_evidence {op1; _})) =\n operation.protocol_data.contents\n in\n check_double_endorsing_evidence_conflict vs oph op1\n\n let wrap_denunciation_conflict kind = function\n | Ok () -> ok_unit\n | Error conflict -> error (Conflicting_denunciation {kind; conflict})\n\n let add_double_endorsing_evidence (type kind) vs oph\n (op1 : kind Kind.consensus Operation.t) =\n match op1.protocol_data.contents with\n | Single (Preendorsement e1) | Single (Endorsement e1) ->\n let double_endorsing_evidences_seen =\n Double_endorsing_evidence_map.add\n (e1.level, e1.round, e1.slot)\n oph\n vs.anonymous_state.double_endorsing_evidences_seen\n in\n {\n vs with\n anonymous_state =\n {vs.anonymous_state with double_endorsing_evidences_seen};\n }\n\n let add_double_endorsement_evidence vs oph\n (operation : Kind.double_endorsement_evidence operation) =\n let (Single (Double_endorsement_evidence {op1; _})) =\n operation.protocol_data.contents\n in\n add_double_endorsing_evidence vs oph op1\n\n let add_double_preendorsement_evidence vs oph\n (operation : Kind.double_preendorsement_evidence operation) =\n let (Single (Double_preendorsement_evidence {op1; _})) =\n operation.protocol_data.contents\n in\n add_double_endorsing_evidence vs oph op1\n\n let remove_double_endorsing_evidence (type kind) vs\n (op : kind Kind.consensus Operation.t) =\n match op.protocol_data.contents with\n | Single (Endorsement e) | Single (Preendorsement e) ->\n let double_endorsing_evidences_seen =\n Double_endorsing_evidence_map.remove\n (e.level, e.round, e.slot)\n vs.anonymous_state.double_endorsing_evidences_seen\n in\n let anonymous_state =\n {vs.anonymous_state with double_endorsing_evidences_seen}\n in\n {vs with anonymous_state}\n\n let remove_double_preendorsement_evidence vs\n (operation : Kind.double_preendorsement_evidence operation) =\n let (Single (Double_preendorsement_evidence {op1; _})) =\n operation.protocol_data.contents\n in\n remove_double_endorsing_evidence vs op1\n\n let remove_double_endorsement_evidence vs\n (operation : Kind.double_endorsement_evidence operation) =\n let (Single (Double_endorsement_evidence {op1; _})) =\n operation.protocol_data.contents\n in\n remove_double_endorsing_evidence vs op1\n\n let check_double_baking_evidence vi\n (operation : Kind.double_baking_evidence operation) =\n let open Lwt_result_syntax in\n let (Single (Double_baking_evidence {bh1; bh2})) =\n operation.protocol_data.contents\n in\n let hash1 = Block_header.hash bh1 in\n let hash2 = Block_header.hash bh2 in\n let*? bh1_fitness = Fitness.from_raw bh1.shell.fitness in\n let round1 = Fitness.round bh1_fitness in\n let*? bh2_fitness = Fitness.from_raw bh2.shell.fitness in\n let round2 = Fitness.round bh2_fitness in\n let*? level1 = Raw_level.of_int32 bh1.shell.level in\n let*? level2 = Raw_level.of_int32 bh2.shell.level in\n let*? () =\n error_unless\n (Raw_level.(level1 = level2)\n && Round.(round1 = round2)\n && (* we require an order on hashes to avoid the existence of\n equivalent evidences *)\n Block_hash.(hash1 < hash2))\n (Invalid_double_baking_evidence\n {hash1; level1; round1; hash2; level2; round2})\n in\n let*? () = check_denunciation_age vi Block level1 in\n let level = Level.from_raw vi.ctxt level1 in\n let committee_size = Constants.consensus_committee_size vi.ctxt in\n let*? slot1 = Round.to_slot round1 ~committee_size in\n let* ctxt, consensus_key1 =\n Stake_distribution.slot_owner vi.ctxt level slot1\n in\n let*? slot2 = Round.to_slot round2 ~committee_size in\n let* ctxt, consensus_key2 =\n Stake_distribution.slot_owner ctxt level slot2\n in\n let delegate1, delegate2 =\n (consensus_key1.delegate, consensus_key2.delegate)\n in\n let*? () =\n error_unless\n Signature.Public_key_hash.(delegate1 = delegate2)\n (Inconsistent_denunciation {kind = Block; delegate1; delegate2})\n in\n let delegate_pk, delegate = (consensus_key1.consensus_pk, delegate1) in\n let* already_slashed =\n Delegate.already_slashed_for_double_baking ctxt delegate level\n in\n let*? () =\n error_unless\n (not already_slashed)\n (Already_denounced {kind = Block; delegate; level})\n in\n let*? () = Block_header.check_signature bh1 vi.chain_id delegate_pk in\n let*? () = Block_header.check_signature bh2 vi.chain_id delegate_pk in\n return_unit\n\n let check_double_baking_evidence_conflict vs oph\n (operation : Kind.double_baking_evidence operation) =\n let (Single (Double_baking_evidence {bh1; _})) =\n operation.protocol_data.contents\n in\n let bh1_fitness =\n Fitness.from_raw bh1.shell.fitness |> function\n | Ok f -> f\n | Error _ ->\n (* We assume the operation valid, it cannot fail anymore *)\n assert false\n in\n let round = Fitness.round bh1_fitness in\n let level = Fitness.level bh1_fitness in\n match\n Double_baking_evidence_map.find\n (level, round)\n vs.anonymous_state.double_baking_evidences_seen\n with\n | None -> ok_unit\n | Some existing ->\n Error (Operation_conflict {existing; new_operation = oph})\n\n let add_double_baking_evidence vs oph\n (operation : Kind.double_baking_evidence operation) =\n let (Single (Double_baking_evidence {bh1; _})) =\n operation.protocol_data.contents\n in\n let bh1_fitness =\n Fitness.from_raw bh1.shell.fitness |> function\n | Ok f -> f\n | Error _ -> assert false\n in\n let round = Fitness.round bh1_fitness in\n let level = Fitness.level bh1_fitness in\n let double_baking_evidences_seen =\n Double_baking_evidence_map.add\n (level, round)\n oph\n vs.anonymous_state.double_baking_evidences_seen\n in\n {\n vs with\n anonymous_state = {vs.anonymous_state with double_baking_evidences_seen};\n }\n\n let remove_double_baking_evidence vs\n (operation : Kind.double_baking_evidence operation) =\n let (Single (Double_baking_evidence {bh1; _})) =\n operation.protocol_data.contents\n in\n let bh1_fitness, level =\n match\n (Fitness.from_raw bh1.shell.fitness, Raw_level.of_int32 bh1.shell.level)\n with\n | Ok v, Ok v' -> (v, v')\n | _ ->\n (* The operation is valid therefore decoding cannot fail *)\n assert false\n in\n let round = Fitness.round bh1_fitness in\n let double_baking_evidences_seen =\n Double_baking_evidence_map.remove\n (level, round)\n vs.anonymous_state.double_baking_evidences_seen\n in\n let anonymous_state =\n {vs.anonymous_state with double_baking_evidences_seen}\n in\n {vs with anonymous_state}\n\n let check_drain_delegate info ~check_signature\n (operation : Kind.drain_delegate Operation.t) =\n let open Lwt_result_syntax in\n let (Single (Drain_delegate {delegate; destination; consensus_key})) =\n operation.protocol_data.contents\n in\n let*! is_registered = Delegate.registered info.ctxt delegate in\n let* () =\n fail_unless\n is_registered\n (Drain_delegate_on_unregistered_delegate delegate)\n in\n let* active_pk = Delegate.Consensus_key.active_pubkey info.ctxt delegate in\n let* () =\n fail_unless\n (Signature.Public_key_hash.equal active_pk.consensus_pkh consensus_key)\n (Invalid_drain_delegate_inactive_key\n {\n delegate;\n consensus_key;\n active_consensus_key = active_pk.consensus_pkh;\n })\n in\n let* () =\n fail_when\n (Signature.Public_key_hash.equal active_pk.consensus_pkh delegate)\n (Invalid_drain_delegate_no_consensus_key delegate)\n in\n let* () =\n fail_when\n (Signature.Public_key_hash.equal destination delegate)\n (Invalid_drain_delegate_noop delegate)\n in\n let*! is_destination_allocated =\n Contract.allocated info.ctxt (Contract.Implicit destination)\n in\n let* balance =\n Contract.get_balance info.ctxt (Contract.Implicit delegate)\n in\n let*? origination_burn =\n if is_destination_allocated then ok Tez.zero\n else\n let cost_per_byte = Constants.cost_per_byte info.ctxt in\n let origination_size = Constants.origination_size info.ctxt in\n Tez.(cost_per_byte *? Int64.of_int origination_size)\n in\n let* drain_fees =\n let*? one_percent = Tez.(balance /? 100L) in\n return Tez.(max one one_percent)\n in\n let*? min_amount = Tez.(origination_burn +? drain_fees) in\n let* () =\n fail_when\n Tez.(balance < min_amount)\n (Invalid_drain_delegate_insufficient_funds_for_burn_or_fees\n {delegate; destination; min_amount})\n in\n let*? () =\n if check_signature then\n Operation.check_signature active_pk.consensus_pk info.chain_id operation\n else ok_unit\n in\n return_unit\n\n let check_drain_delegate_conflict state oph\n (operation : Kind.drain_delegate Operation.t) =\n let (Single (Drain_delegate {delegate; _})) =\n operation.protocol_data.contents\n in\n match\n Signature.Public_key_hash.Map.find_opt\n delegate\n state.manager_state.managers_seen\n with\n | None -> ok_unit\n | Some existing ->\n Error (Operation_conflict {existing; new_operation = oph})\n\n let wrap_drain_delegate_conflict (operation : Kind.drain_delegate Operation.t)\n =\n let (Single (Drain_delegate {delegate; _})) =\n operation.protocol_data.contents\n in\n function\n | Ok () -> ok_unit\n | Error conflict -> error (Conflicting_drain_delegate {delegate; conflict})\n\n let add_drain_delegate state oph (operation : Kind.drain_delegate Operation.t)\n =\n let (Single (Drain_delegate {delegate; _})) =\n operation.protocol_data.contents\n in\n let managers_seen =\n Signature.Public_key_hash.Map.add\n delegate\n oph\n state.manager_state.managers_seen\n in\n {state with manager_state = {managers_seen}}\n\n let remove_drain_delegate state (operation : Kind.drain_delegate Operation.t)\n =\n let (Single (Drain_delegate {delegate; _})) =\n operation.protocol_data.contents\n in\n let managers_seen =\n Signature.Public_key_hash.Map.remove\n delegate\n state.manager_state.managers_seen\n in\n {state with manager_state = {managers_seen}}\n\n let check_seed_nonce_revelation vi\n (operation : Kind.seed_nonce_revelation operation) =\n let open Lwt_result_syntax in\n let (Single (Seed_nonce_revelation {level = commitment_raw_level; nonce})) =\n operation.protocol_data.contents\n in\n let commitment_level = Level.from_raw vi.ctxt commitment_raw_level in\n let* () = Nonce.check_unrevealed vi.ctxt commitment_level nonce in\n return_unit\n\n let check_seed_nonce_revelation_conflict vs oph\n (operation : Kind.seed_nonce_revelation operation) =\n let (Single (Seed_nonce_revelation {level = commitment_raw_level; _})) =\n operation.protocol_data.contents\n in\n match\n Raw_level.Map.find_opt\n commitment_raw_level\n vs.anonymous_state.seed_nonce_levels_seen\n with\n | None -> ok_unit\n | Some existing ->\n Error (Operation_conflict {existing; new_operation = oph})\n\n let wrap_seed_nonce_revelation_conflict = function\n | Ok () -> ok_unit\n | Error conflict -> error (Conflicting_nonce_revelation conflict)\n\n let add_seed_nonce_revelation vs oph\n (operation : Kind.seed_nonce_revelation operation) =\n let (Single (Seed_nonce_revelation {level = commitment_raw_level; _})) =\n operation.protocol_data.contents\n in\n let seed_nonce_levels_seen =\n Raw_level.Map.add\n commitment_raw_level\n oph\n vs.anonymous_state.seed_nonce_levels_seen\n in\n let anonymous_state = {vs.anonymous_state with seed_nonce_levels_seen} in\n {vs with anonymous_state}\n\n let remove_seed_nonce_revelation vs\n (operation : Kind.seed_nonce_revelation operation) =\n let (Single (Seed_nonce_revelation {level = commitment_raw_level; _})) =\n operation.protocol_data.contents\n in\n let seed_nonce_levels_seen =\n Raw_level.Map.remove\n commitment_raw_level\n vs.anonymous_state.seed_nonce_levels_seen\n in\n let anonymous_state = {vs.anonymous_state with seed_nonce_levels_seen} in\n {vs with anonymous_state}\n\n let check_vdf_revelation vi (operation : Kind.vdf_revelation operation) =\n let open Lwt_result_syntax in\n let (Single (Vdf_revelation {solution})) =\n operation.protocol_data.contents\n in\n let* () = Seed.check_vdf vi.ctxt solution in\n return_unit\n\n let check_vdf_revelation_conflict vs oph =\n match vs.anonymous_state.vdf_solution_seen with\n | None -> ok_unit\n | Some existing ->\n Error (Operation_conflict {existing; new_operation = oph})\n\n let wrap_vdf_revelation_conflict = function\n | Ok () -> ok_unit\n | Error conflict -> error (Conflicting_vdf_revelation conflict)\n\n let add_vdf_revelation vs oph =\n {\n vs with\n anonymous_state = {vs.anonymous_state with vdf_solution_seen = Some oph};\n }\n\n let remove_vdf_revelation vs =\n let anonymous_state = {vs.anonymous_state with vdf_solution_seen = None} in\n {vs with anonymous_state}\nend\n\nmodule Manager = struct\n open Validate_errors.Manager\n\n (** State that simulates changes from individual operations that have\n an effect on future operations inside the same batch. *)\n type batch_state = {\n balance : Tez.t;\n (** Remaining balance in the contract, used to simulate the\n payment of fees by each operation in the batch. *)\n is_allocated : bool;\n (** Track whether the contract is still allocated. Indeed,\n previous operations' fee payment may empty the contract and\n this may deallocate the contract.\n\n TODO: https://gitlab.com/tezos/tezos/-/issues/3209 Change\n empty account cleanup mechanism to avoid the need for this\n field. *)\n total_gas_used : Gas.Arith.fp;\n }\n\n (** Check a few simple properties of the batch, and return the\n initial {!batch_state} and the contract public key.\n\n Invariants checked:\n\n - All operations in a batch have the same source.\n\n - The source's contract is allocated.\n\n - The counters in a batch are successive, and the first of them\n is the source's next expected counter.\n\n - A batch contains at most one Reveal operation that must occur\n in first position.\n\n - The source's public key has been revealed (either before the\n considered batch, or during its first operation).\n\n Note that currently, the [op] batch contains only one signature,\n so all operations in the batch are required to originate from the\n same manager. This may change in the future, in order to allow\n several managers to group-sign a sequence of operations. *)\n let check_sanity_and_find_public_key vi\n (contents_list : _ Kind.manager contents_list) =\n let open Result_syntax in\n let check_source_and_counter ~expected_source ~source ~previous_counter\n ~counter =\n let* () =\n error_unless\n (Signature.Public_key_hash.equal expected_source source)\n Inconsistent_sources\n in\n error_unless\n Manager_counter.(succ previous_counter = counter)\n Inconsistent_counters\n in\n let rec check_batch_tail_sanity :\n type kind.\n public_key_hash ->\n Manager_counter.t ->\n kind Kind.manager contents_list ->\n unit tzresult =\n fun expected_source previous_counter -> function\n | Single (Manager_operation {operation = Reveal _key; _}) ->\n error Incorrect_reveal_position\n | Cons (Manager_operation {operation = Reveal _key; _}, _res) ->\n error Incorrect_reveal_position\n | Single (Manager_operation {source; counter; _}) ->\n check_source_and_counter\n ~expected_source\n ~source\n ~previous_counter\n ~counter\n | Cons (Manager_operation {source; counter; _}, rest) ->\n let open Result_syntax in\n let* () =\n check_source_and_counter\n ~expected_source\n ~source\n ~previous_counter\n ~counter\n in\n check_batch_tail_sanity source counter rest\n in\n let check_batch :\n type kind.\n kind Kind.manager contents_list ->\n (public_key_hash * public_key option * Manager_counter.t) tzresult =\n fun contents_list ->\n match contents_list with\n | Single (Manager_operation {source; operation = Reveal key; counter; _})\n ->\n ok (source, Some key, counter)\n | Single (Manager_operation {source; counter; _}) ->\n ok (source, None, counter)\n | Cons\n (Manager_operation {source; operation = Reveal key; counter; _}, rest)\n ->\n check_batch_tail_sanity source counter rest >>? fun () ->\n ok (source, Some key, counter)\n | Cons (Manager_operation {source; counter; _}, rest) ->\n check_batch_tail_sanity source counter rest >>? fun () ->\n ok (source, None, counter)\n in\n let open Lwt_result_syntax in\n let*? source, revealed_key, first_counter = check_batch contents_list in\n let* balance = Contract.check_allocated_and_get_balance vi.ctxt source in\n let* () = Contract.check_counter_increment vi.ctxt source first_counter in\n let* pk =\n (* Note that it is important to always retrieve the public\n key. This includes the case where the key ends up not being\n used because the signature check is skipped in\n {!validate_manager_operation} called with\n [~check_signature:false]. Indeed, the mempool may use\n this argument when it has already checked the signature of\n the operation in the past; but if there has been a branch\n reorganization since then, the key might not be revealed in\n the new branch anymore, in which case\n {!Contract.get_manager_key} will return an error. *)\n match revealed_key with\n | Some pk -> return pk\n | None -> Contract.get_manager_key vi.ctxt source\n in\n let initial_batch_state =\n {\n balance;\n (* Initial contract allocation is ensured by the success of\n the call to {!Contract.check_allocated_and_get_balance}\n above. *)\n is_allocated = true;\n total_gas_used = Gas.Arith.zero;\n }\n in\n return (initial_batch_state, pk)\n\n let check_gas_limit info ~gas_limit =\n Gas.check_gas_limit\n ~hard_gas_limit_per_operation:\n info.manager_info.hard_gas_limit_per_operation\n ~gas_limit\n\n let check_storage_limit vi storage_limit =\n error_unless\n Compare.Z.(\n storage_limit <= vi.manager_info.hard_storage_limit_per_operation\n && storage_limit >= Z.zero)\n Fees.Storage_limit_too_high\n\n let assert_tx_rollup_feature_enabled vi =\n let open Result_syntax in\n let* sunset =\n Raw_level.of_int32 (Constants.tx_rollup_sunset_level vi.ctxt)\n in\n error_unless\n (Constants.tx_rollup_enable vi.ctxt\n && Raw_level.(vi.current_level.level < sunset))\n Tx_rollup_feature_disabled\n\n let assert_sc_rollup_feature_enabled vi =\n error_unless (Constants.sc_rollup_enable vi.ctxt) Sc_rollup_feature_disabled\n\n let assert_pvm_kind_enabled vi kind =\n error_when\n ((not (Constants.sc_rollup_arith_pvm_enable vi.ctxt))\n && Sc_rollup.Kind.(equal kind Example_arith))\n Sc_rollup_arith_pvm_disabled\n\n let assert_not_zero_messages messages =\n match messages with\n | [] -> error Sc_rollup_errors.Sc_rollup_add_zero_messages\n | _ -> ok_unit\n\n let assert_zk_rollup_feature_enabled vi =\n error_unless (Constants.zk_rollup_enable vi.ctxt) Zk_rollup_feature_disabled\n\n let consume_decoding_gas remaining_gas lexpr =\n record_trace Gas_quota_exceeded_init_deserialize\n @@ (* Fail early if the operation does not have enough gas to\n cover the deserialization cost. We always consider the full\n deserialization cost, independently from the internal state\n of the lazy_expr. Otherwise we might risk getting different\n results if the operation has already been deserialized\n before (e.g. when retrieved in JSON format). Note that the\n lazy_expr is not actually decoded here; its deserialization\n cost is estimated from the size of its bytes. *)\n Script.consume_decoding_gas remaining_gas lexpr\n\n let validate_tx_rollup_submit_batch vi remaining_gas content =\n let open Result_syntax in\n let* () = assert_tx_rollup_feature_enabled vi in\n let _message, message_size = Tx_rollup_message.make_batch content in\n let* cost = Tx_rollup_gas.hash_cost message_size in\n let size_limit = Constants.tx_rollup_hard_size_limit_per_message vi.ctxt in\n let* (_ : Gas.Arith.fp) = Gas.consume_from remaining_gas cost in\n error_unless\n Compare.Int.(message_size <= size_limit)\n Tx_rollup_errors.Message_size_exceeds_limit\n\n let validate_tx_rollup_dispatch_tickets vi remaining_gas operation =\n let open Result_syntax in\n let* () = assert_tx_rollup_feature_enabled vi in\n let (Tx_rollup_dispatch_tickets {tickets_info; message_result_path; _}) =\n operation\n in\n let Constants.Parametric.\n {max_messages_per_inbox; max_withdrawals_per_batch; _} =\n Constants.tx_rollup vi.ctxt\n in\n let* () =\n Tx_rollup_errors.check_path_depth\n `Commitment\n (Tx_rollup_commitment.Merkle.path_depth message_result_path)\n ~count_limit:max_messages_per_inbox\n in\n let* () =\n error_when\n Compare.List_length_with.(tickets_info = 0)\n Tx_rollup_errors.No_withdrawals_to_dispatch\n in\n let* () =\n error_when\n Compare.List_length_with.(tickets_info > max_withdrawals_per_batch)\n Tx_rollup_errors.Too_many_withdrawals\n in\n let* (_ : Gas.Arith.fp) =\n record_trace\n Gas_quota_exceeded_init_deserialize\n (List.fold_left_e\n (fun remaining_gas Tx_rollup_reveal.{contents; ty; _} ->\n let* remaining_gas =\n Script.consume_decoding_gas remaining_gas contents\n in\n Script.consume_decoding_gas remaining_gas ty)\n remaining_gas\n tickets_info)\n in\n return_unit\n\n let validate_tx_rollup_rejection vi operation =\n let open Result_syntax in\n let* () = assert_tx_rollup_feature_enabled vi in\n let (Tx_rollup_rejection\n {message_path; message_result_path; previous_message_result_path; _})\n =\n operation\n in\n let Constants.Parametric.{max_messages_per_inbox; _} =\n Constants.tx_rollup vi.ctxt\n in\n let* () =\n Tx_rollup_errors.check_path_depth\n `Inbox\n (Tx_rollup_inbox.Merkle.path_depth message_path)\n ~count_limit:max_messages_per_inbox\n in\n let* () =\n Tx_rollup_errors.check_path_depth\n `Commitment\n (Tx_rollup_commitment.Merkle.path_depth message_result_path)\n ~count_limit:max_messages_per_inbox\n in\n Tx_rollup_errors.check_path_depth\n `Commitment\n (Tx_rollup_commitment.Merkle.path_depth previous_message_result_path)\n ~count_limit:max_messages_per_inbox\n\n let may_trace_gas_limit_too_high info =\n match info.mode with\n | Application _ | Partial_validation _ | Construction _ -> fun x -> x\n | Mempool ->\n (* [Gas.check_limit] will only\n raise a \"temporary\" error, however when\n {!validate_operation} is called on a batch in isolation\n (like e.g. in the mempool) it must \"refuse\" operations\n whose total gas limit (the sum of the [gas_limit]s of each\n operation) is already above the block limit. We add the\n \"permanent\" error [Gas.Gas_limit_too_high] on top of the\n trace to this effect. *)\n record_trace Gas.Gas_limit_too_high\n\n let check_contents (type kind) vi batch_state\n (contents : kind Kind.manager contents) remaining_block_gas =\n let open Lwt_result_syntax in\n let (Manager_operation\n {source; fee; counter = _; operation; gas_limit; storage_limit}) =\n contents\n in\n let*? () = check_gas_limit vi ~gas_limit in\n let total_gas_used =\n Gas.Arith.(add batch_state.total_gas_used (fp gas_limit))\n in\n let*? () =\n may_trace_gas_limit_too_high vi\n @@ error_unless\n Gas.Arith.(fp total_gas_used <= remaining_block_gas)\n Gas.Block_quota_exceeded\n in\n let*? remaining_gas =\n record_trace\n Insufficient_gas_for_manager\n (Gas.consume_from\n (Gas.Arith.fp gas_limit)\n Michelson_v1_gas.Cost_of.manager_operation)\n in\n let*? () = check_storage_limit vi storage_limit in\n let*? () =\n (* {!Contract.must_be_allocated} has already been called while\n initializing [batch_state]. This checks that the contract has\n not been emptied by spending fees for previous operations in\n the batch. *)\n error_unless\n batch_state.is_allocated\n (Contract_storage.Empty_implicit_contract source)\n in\n let*? () =\n let open Result_syntax in\n match operation with\n | Reveal pk -> Contract.check_public_key pk source\n | Transaction {parameters; _} ->\n let* (_ : Gas.Arith.fp) =\n consume_decoding_gas remaining_gas parameters\n in\n return_unit\n | Origination {script; _} ->\n let* remaining_gas = consume_decoding_gas remaining_gas script.code in\n let* (_ : Gas.Arith.fp) =\n consume_decoding_gas remaining_gas script.storage\n in\n return_unit\n | Register_global_constant {value} ->\n let* (_ : Gas.Arith.fp) = consume_decoding_gas remaining_gas value in\n return_unit\n | Delegation (Some pkh) -> Delegate.check_not_tz4 pkh\n | Update_consensus_key pk -> Delegate.Consensus_key.check_not_tz4 pk\n | Delegation None | Set_deposits_limit _ | Increase_paid_storage _ ->\n return_unit\n | Tx_rollup_origination -> assert_tx_rollup_feature_enabled vi\n | Tx_rollup_submit_batch {content; _} ->\n validate_tx_rollup_submit_batch vi remaining_gas content\n | Tx_rollup_commit _ | Tx_rollup_return_bond _\n | Tx_rollup_finalize_commitment _ | Tx_rollup_remove_commitment _ ->\n assert_tx_rollup_feature_enabled vi\n | Transfer_ticket {contents; ty; _} ->\n let* remaining_gas = consume_decoding_gas remaining_gas contents in\n let* (_ : Gas.Arith.fp) = consume_decoding_gas remaining_gas ty in\n return_unit\n | Tx_rollup_dispatch_tickets _ ->\n validate_tx_rollup_dispatch_tickets vi remaining_gas operation\n | Tx_rollup_rejection _ -> validate_tx_rollup_rejection vi operation\n | Sc_rollup_originate {kind; _} ->\n let* () = assert_sc_rollup_feature_enabled vi in\n assert_pvm_kind_enabled vi kind\n | Sc_rollup_cement _ | Sc_rollup_publish _ | Sc_rollup_refute _\n | Sc_rollup_timeout _ | Sc_rollup_execute_outbox_message _ ->\n assert_sc_rollup_feature_enabled vi\n | Sc_rollup_add_messages {messages; _} ->\n let* () = assert_sc_rollup_feature_enabled vi in\n assert_not_zero_messages messages\n | Sc_rollup_recover_bond _ ->\n (* TODO: https://gitlab.com/tezos/tezos/-/issues/3063\n Should we successfully precheck Sc_rollup_recover_bond and any\n (simple) Sc rollup operation, or should we add some some checks to make\n the operations Branch_delayed if they cannot be successfully\n prechecked? *)\n assert_sc_rollup_feature_enabled vi\n | Dal_publish_slot_header slot_header ->\n Dal_apply.validate_publish_slot_header vi.ctxt slot_header\n | Zk_rollup_origination _ | Zk_rollup_publish _ | Zk_rollup_update _ ->\n assert_zk_rollup_feature_enabled vi\n in\n (* Gas should no longer be consumed below this point, because it\n would not take into account any gas consumed during the pattern\n matching right above. If you really need to consume gas here, then you\n must make this pattern matching return the [remaining_gas].*)\n let* balance, is_allocated =\n Contract.simulate_spending\n vi.ctxt\n ~balance:batch_state.balance\n ~amount:fee\n source\n in\n return {total_gas_used; balance; is_allocated}\n\n (** This would be [fold_left_es (check_contents vi) batch_state\n contents_list] if [contents_list] were an ordinary [list]. *)\n let rec check_contents_list :\n type kind.\n info ->\n batch_state ->\n kind Kind.manager contents_list ->\n Gas.Arith.fp ->\n Gas.Arith.fp tzresult Lwt.t =\n fun vi batch_state contents_list remaining_gas ->\n let open Lwt_result_syntax in\n match contents_list with\n | Single contents ->\n let* batch_state =\n check_contents vi batch_state contents remaining_gas\n in\n return batch_state.total_gas_used\n | Cons (contents, tail) ->\n let* batch_state =\n check_contents vi batch_state contents remaining_gas\n in\n check_contents_list vi batch_state tail remaining_gas\n\n let check_manager_operation vi ~check_signature\n (operation : _ Kind.manager operation) remaining_block_gas =\n let open Lwt_result_syntax in\n let contents_list = operation.protocol_data.contents in\n let* batch_state, source_pk =\n check_sanity_and_find_public_key vi contents_list\n in\n let* gas_used =\n check_contents_list vi batch_state contents_list remaining_block_gas\n in\n let*? () =\n if check_signature then\n Operation.check_signature source_pk vi.chain_id operation\n else ok_unit\n in\n return gas_used\n\n let check_manager_operation_conflict (type kind) vs oph\n (operation : kind Kind.manager operation) =\n let source =\n match operation.protocol_data.contents with\n | Single (Manager_operation {source; _})\n | Cons (Manager_operation {source; _}, _) ->\n source\n in\n (* One-operation-per-manager-per-block restriction (1M) *)\n match\n Signature.Public_key_hash.Map.find_opt\n source\n vs.manager_state.managers_seen\n with\n | None -> ok_unit\n | Some existing ->\n Error (Operation_conflict {existing; new_operation = oph})\n\n let wrap_check_manager_operation_conflict (type kind)\n (operation : kind Kind.manager operation) =\n let source =\n match operation.protocol_data.contents with\n | Single (Manager_operation {source; _})\n | Cons (Manager_operation {source; _}, _) ->\n source\n in\n function\n | Ok () -> ok_unit\n | Error conflict -> error (Manager_restriction {source; conflict})\n\n let add_manager_operation (type kind) vs oph\n (operation : kind Kind.manager operation) =\n let source =\n match operation.protocol_data.contents with\n | Single (Manager_operation {source; _})\n | Cons (Manager_operation {source; _}, _) ->\n source\n in\n let managers_seen =\n Signature.Public_key_hash.Map.add\n source\n oph\n vs.manager_state.managers_seen\n in\n {vs with manager_state = {managers_seen}}\n\n (* Return the new [block_state] with the updated remaining gas used:\n - In non-mempool modes, this value is\n [block_state.remaining_block_gas], in which the gas from the\n validated operation has been subtracted.\n\n - In [Mempool] mode, the [block_state] should remain\n unchanged. Indeed, we only want each batch to not exceed the\n block limit individually, without taking other operations\n into account. *)\n let may_update_remaining_gas_used mode (block_state : block_state)\n operation_gas_used =\n match mode with\n | Application _ | Partial_validation _ | Construction _ ->\n let remaining_block_gas =\n Gas.Arith.(sub block_state.remaining_block_gas operation_gas_used)\n in\n {block_state with remaining_block_gas}\n | Mempool -> block_state\n\n let remove_manager_operation (type kind) vs\n (operation : kind Kind.manager operation) =\n let source =\n match operation.protocol_data.contents with\n | Single (Manager_operation {source; _})\n | Cons (Manager_operation {source; _}, _) ->\n source\n in\n let managers_seen =\n Signature.Public_key_hash.Map.remove source vs.manager_state.managers_seen\n in\n {vs with manager_state = {managers_seen}}\n\n let validate_manager_operation ~check_signature info operation_state\n block_state oph operation =\n let open Lwt_result_syntax in\n let* gas_used =\n check_manager_operation\n info\n ~check_signature\n operation\n block_state.remaining_block_gas\n in\n let*? () =\n check_manager_operation_conflict operation_state oph operation\n |> wrap_check_manager_operation_conflict operation\n in\n let operation_state = add_manager_operation operation_state oph operation in\n let block_state =\n may_update_remaining_gas_used info.mode block_state gas_used\n in\n return {info; operation_state; block_state}\nend\n\nlet init_validation_state ctxt mode chain_id all_expected_consensus_features\n ~predecessor_level =\n let info = init_info ctxt mode chain_id all_expected_consensus_features in\n let operation_state = init_operation_conflict_state ~predecessor_level in\n let block_state = init_block_state info in\n {info; operation_state; block_state}\n\n(* Pre-condition: Shell block headers' checks have already been done.\n These checks must ensure that:\n - the block header level is the succ of the predecessor block level\n - the timestamp of the predecessor is lower than the current block's\n - the fitness of the block is greater than its predecessor's\n - the number of operations by validation passes does not exceed the quota\n established by the protocol\n - the size of an operation does not exceed [max_operation_data_length]\n*)\nlet begin_any_application ctxt chain_id ~predecessor_level\n ~predecessor_timestamp (block_header : Block_header.t) fitness ~is_partial =\n let open Lwt_result_syntax in\n let predecessor_round = Fitness.predecessor_round fitness in\n let round = Fitness.round fitness in\n let current_level = Level.current ctxt in\n let* ctxt, _slot, block_producer =\n Stake_distribution.baking_rights_owner ctxt current_level ~round\n in\n let*? () =\n Block_header.begin_validate_block_header\n ~block_header\n ~chain_id\n ~predecessor_timestamp\n ~predecessor_round\n ~fitness\n ~timestamp:block_header.shell.timestamp\n ~delegate_pk:block_producer.consensus_pk\n ~round_durations:(Constants.round_durations ctxt)\n ~proof_of_work_threshold:(Constants.proof_of_work_threshold ctxt)\n ~expected_commitment:current_level.expected_commitment\n in\n let* () =\n Consensus.check_frozen_deposits_are_positive ctxt block_producer.delegate\n in\n let* ctxt, _slot, payload_producer =\n Stake_distribution.baking_rights_owner\n ctxt\n current_level\n ~round:block_header.protocol_data.contents.payload_round\n in\n let payload_hash = block_header.protocol_data.contents.payload_hash in\n let predecessor_hash = block_header.shell.predecessor in\n let block_finalization_info =\n {\n fitness;\n block_producer;\n payload_producer;\n predecessor_hash;\n block_data_contents = block_header.protocol_data.contents;\n }\n in\n let mode =\n if is_partial then Partial_validation block_finalization_info\n else Application block_finalization_info\n in\n let all_expected_consensus_features =\n Consensus.expected_features_for_application\n ctxt\n fitness\n payload_hash\n ~predecessor_level\n ~predecessor_round\n ~predecessor_hash\n in\n let predecessor_level = predecessor_level.level in\n return\n (init_validation_state\n ctxt\n mode\n chain_id\n all_expected_consensus_features\n ~predecessor_level)\n\nlet begin_partial_validation ctxt chain_id ~predecessor_level\n ~predecessor_timestamp block_header fitness =\n begin_any_application\n ctxt\n chain_id\n ~predecessor_level\n ~predecessor_timestamp\n block_header\n fitness\n ~is_partial:true\n\nlet begin_application ctxt chain_id ~predecessor_level ~predecessor_timestamp\n block_header fitness =\n begin_any_application\n ctxt\n chain_id\n ~predecessor_level\n ~predecessor_timestamp\n block_header\n fitness\n ~is_partial:false\n\nlet begin_full_construction ctxt chain_id ~predecessor_level ~predecessor_round\n ~predecessor_timestamp ~predecessor_hash round\n (header_contents : Block_header.contents) =\n let open Lwt_result_syntax in\n let round_durations = Constants.round_durations ctxt in\n let timestamp = Timestamp.current ctxt in\n let*? () =\n Block_header.check_timestamp\n round_durations\n ~timestamp\n ~round\n ~predecessor_timestamp\n ~predecessor_round\n in\n let current_level = Level.current ctxt in\n let* ctxt, _slot, block_producer =\n Stake_distribution.baking_rights_owner ctxt current_level ~round\n in\n let* () =\n Consensus.check_frozen_deposits_are_positive ctxt block_producer.delegate\n in\n let* ctxt, _slot, payload_producer =\n Stake_distribution.baking_rights_owner\n ctxt\n current_level\n ~round:header_contents.payload_round\n in\n let all_expected_consensus_features =\n Consensus.expected_features_for_construction\n ctxt\n round\n header_contents.payload_hash\n ~predecessor_level\n ~predecessor_round\n ~predecessor_hash\n in\n let predecessor_level = predecessor_level.level in\n let validation_state =\n init_validation_state\n ctxt\n (Construction\n {\n predecessor_round;\n predecessor_hash;\n round;\n block_data_contents = header_contents;\n block_producer;\n payload_producer;\n })\n chain_id\n all_expected_consensus_features\n ~predecessor_level\n in\n return validation_state\n\nlet begin_partial_construction ctxt chain_id ~predecessor_level\n ~predecessor_round ~grandparent_round =\n let all_expected_consensus_features =\n Consensus.expected_features_for_partial_construction\n ctxt\n ~predecessor_level\n ~predecessor_round\n ~grandparent_round\n in\n let predecessor_level = predecessor_level.level in\n let validation_state =\n init_validation_state\n ctxt\n Mempool\n chain_id\n all_expected_consensus_features\n ~predecessor_level\n in\n validation_state\n\nlet begin_no_predecessor_info ctxt chain_id =\n let all_expected_consensus_features =\n {\n expected_preendorsement =\n No_predecessor_info_cannot_validate_preendorsement;\n expected_endorsement = No_predecessor_info_cannot_validate_endorsement;\n expected_grandparent_endorsement_for_partial_construction = None;\n }\n in\n let current_level = Level.current ctxt in\n let predecessor_level =\n match Raw_level.pred current_level.level with\n | None -> current_level.level\n | Some level -> level\n in\n init_validation_state\n ctxt\n Mempool\n chain_id\n all_expected_consensus_features\n ~predecessor_level\n\nlet check_operation ?(check_signature = true) info (type kind)\n (operation : kind operation) : unit tzresult Lwt.t =\n let open Lwt_result_syntax in\n match operation.protocol_data.contents with\n | Single (Preendorsement _) ->\n let* (_voting_power : int) =\n Consensus.check_preendorsement info ~check_signature operation\n in\n return_unit\n | Single (Endorsement _) ->\n let* (_kind : Consensus.endorsement_kind) =\n Consensus.check_endorsement info ~check_signature operation\n in\n return_unit\n | Single (Dal_attestation _) -> Consensus.check_dal_attestation info operation\n | Single (Proposals _) ->\n Voting.check_proposals info ~check_signature operation\n | Single (Ballot _) -> Voting.check_ballot info ~check_signature operation\n | Single (Activate_account _) ->\n Anonymous.check_activate_account info operation\n | Single (Double_preendorsement_evidence _) ->\n Anonymous.check_double_preendorsement_evidence info operation\n | Single (Double_endorsement_evidence _) ->\n Anonymous.check_double_endorsement_evidence info operation\n | Single (Double_baking_evidence _) ->\n Anonymous.check_double_baking_evidence info operation\n | Single (Drain_delegate _) ->\n Anonymous.check_drain_delegate info ~check_signature operation\n | Single (Seed_nonce_revelation _) ->\n Anonymous.check_seed_nonce_revelation info operation\n | Single (Vdf_revelation _) -> Anonymous.check_vdf_revelation info operation\n | Single (Manager_operation _) ->\n let remaining_gas =\n Gas.Arith.fp (Constants.hard_gas_limit_per_block info.ctxt)\n in\n let* (_remaining_gas : Gas.Arith.fp) =\n Manager.check_manager_operation\n info\n ~check_signature\n operation\n remaining_gas\n in\n return_unit\n | Cons (Manager_operation _, _) ->\n let remaining_gas =\n Gas.Arith.fp (Constants.hard_gas_limit_per_block info.ctxt)\n in\n let* (_remaining_gas : Gas.Arith.fp) =\n Manager.check_manager_operation\n info\n ~check_signature\n operation\n remaining_gas\n in\n return_unit\n | Single (Failing_noop _) -> tzfail Validate_errors.Failing_noop_error\n\nlet check_operation_conflict (type kind) operation_conflict_state oph\n (operation : kind operation) =\n match operation.protocol_data.contents with\n | Single (Preendorsement _) ->\n Consensus.check_preendorsement_conflict\n operation_conflict_state\n oph\n operation\n | Single (Endorsement _) ->\n Consensus.check_endorsement_conflict\n operation_conflict_state\n oph\n operation\n | Single (Dal_attestation _) ->\n Consensus.check_dal_attestation_conflict\n operation_conflict_state\n oph\n operation\n | Single (Proposals _) ->\n Voting.check_proposals_conflict operation_conflict_state oph operation\n | Single (Ballot _) ->\n Voting.check_ballot_conflict operation_conflict_state oph operation\n | Single (Activate_account _) ->\n Anonymous.check_activate_account_conflict\n operation_conflict_state\n oph\n operation\n | Single (Double_preendorsement_evidence _) ->\n Anonymous.check_double_preendorsement_evidence_conflict\n operation_conflict_state\n oph\n operation\n | Single (Double_endorsement_evidence _) ->\n Anonymous.check_double_endorsement_evidence_conflict\n operation_conflict_state\n oph\n operation\n | Single (Double_baking_evidence _) ->\n Anonymous.check_double_baking_evidence_conflict\n operation_conflict_state\n oph\n operation\n | Single (Drain_delegate _) ->\n Anonymous.check_drain_delegate_conflict\n operation_conflict_state\n oph\n operation\n | Single (Seed_nonce_revelation _) ->\n Anonymous.check_seed_nonce_revelation_conflict\n operation_conflict_state\n oph\n operation\n | Single (Vdf_revelation _) ->\n Anonymous.check_vdf_revelation_conflict operation_conflict_state oph\n | Single (Manager_operation _) ->\n Manager.check_manager_operation_conflict\n operation_conflict_state\n oph\n operation\n | Cons (Manager_operation _, _) ->\n Manager.check_manager_operation_conflict\n operation_conflict_state\n oph\n operation\n | Single (Failing_noop _) -> (* Nothing to do *) ok_unit\n\nlet add_valid_operation operation_conflict_state oph (type kind)\n (operation : kind operation) =\n match operation.protocol_data.contents with\n | Single (Preendorsement _) ->\n Consensus.add_preendorsement operation_conflict_state oph operation\n | Single (Endorsement consensus_content) ->\n let endorsement_kind =\n if\n Consensus.is_normal_endorsement_assuming_valid\n operation_conflict_state\n consensus_content\n then Consensus.Normal_endorsement 0\n else Grandparent_endorsement\n in\n Consensus.add_endorsement\n operation_conflict_state\n oph\n operation\n endorsement_kind\n | Single (Dal_attestation _) ->\n Consensus.add_dal_attestation operation_conflict_state oph operation\n | Single (Proposals _) ->\n Voting.add_proposals operation_conflict_state oph operation\n | Single (Ballot _) ->\n Voting.add_ballot operation_conflict_state oph operation\n | Single (Activate_account _) ->\n Anonymous.add_activate_account operation_conflict_state oph operation\n | Single (Double_preendorsement_evidence _) ->\n Anonymous.add_double_preendorsement_evidence\n operation_conflict_state\n oph\n operation\n | Single (Double_endorsement_evidence _) ->\n Anonymous.add_double_endorsement_evidence\n operation_conflict_state\n oph\n operation\n | Single (Double_baking_evidence _) ->\n Anonymous.add_double_baking_evidence\n operation_conflict_state\n oph\n operation\n | Single (Drain_delegate _) ->\n Anonymous.add_drain_delegate operation_conflict_state oph operation\n | Single (Seed_nonce_revelation _) ->\n Anonymous.add_seed_nonce_revelation operation_conflict_state oph operation\n | Single (Vdf_revelation _) ->\n Anonymous.add_vdf_revelation operation_conflict_state oph\n | Single (Manager_operation _) ->\n Manager.add_manager_operation operation_conflict_state oph operation\n | Cons (Manager_operation _, _) ->\n Manager.add_manager_operation operation_conflict_state oph operation\n | Single (Failing_noop _) -> (* Nothing to do *) operation_conflict_state\n\n(* Hypothesis:\n - the [operation] has been validated and is present in [vs];\n - this function is only valid for the mempool mode. *)\nlet remove_operation operation_conflict_state (type kind)\n (operation : kind operation) =\n match operation.protocol_data.contents with\n | Single (Preendorsement _) ->\n Consensus.remove_preendorsement operation_conflict_state operation\n | Single (Endorsement _) ->\n Consensus.remove_endorsement operation_conflict_state operation\n | Single (Dal_attestation _) ->\n Consensus.remove_dal_attestation operation_conflict_state operation\n | Single (Proposals _) ->\n Voting.remove_proposals operation_conflict_state operation\n | Single (Ballot _) -> Voting.remove_ballot operation_conflict_state operation\n | Single (Activate_account _) ->\n Anonymous.remove_activate_account operation_conflict_state operation\n | Single (Double_preendorsement_evidence _) ->\n Anonymous.remove_double_preendorsement_evidence\n operation_conflict_state\n operation\n | Single (Double_endorsement_evidence _) ->\n Anonymous.remove_double_endorsement_evidence\n operation_conflict_state\n operation\n | Single (Double_baking_evidence _) ->\n Anonymous.remove_double_baking_evidence operation_conflict_state operation\n | Single (Drain_delegate _) ->\n Anonymous.remove_drain_delegate operation_conflict_state operation\n | Single (Seed_nonce_revelation _) ->\n Anonymous.remove_seed_nonce_revelation operation_conflict_state operation\n | Single (Vdf_revelation _) ->\n Anonymous.remove_vdf_revelation operation_conflict_state\n | Single (Manager_operation _) ->\n Manager.remove_manager_operation operation_conflict_state operation\n | Cons (Manager_operation _, _) ->\n Manager.remove_manager_operation operation_conflict_state operation\n | Single (Failing_noop _) -> (* Nothing to do *) operation_conflict_state\n\nlet check_validation_pass_consistency vi vs validation_pass =\n let open Lwt_result_syntax in\n match vi.mode with\n | Mempool | Construction _ -> return vs\n | Application _ | Partial_validation _ -> (\n match (vs.last_op_validation_pass, validation_pass) with\n | None, validation_pass ->\n return {vs with last_op_validation_pass = validation_pass}\n | Some previous_vp, Some validation_pass ->\n let* () =\n fail_unless\n Compare.Int.(previous_vp <= validation_pass)\n (Validate_errors.Block.Inconsistent_validation_passes_in_block\n {expected = previous_vp; provided = validation_pass})\n in\n return {vs with last_op_validation_pass = Some validation_pass}\n | Some _, None -> tzfail Validate_errors.Failing_noop_error)\n\n(** Increment [vs.op_count] for all operations, and record\n non-consensus operation hashes in [vs.recorded_operations_rev]. *)\nlet record_operation vs ophash validation_pass_opt =\n let op_count = vs.op_count + 1 in\n match validation_pass_opt with\n | Some n when Compare.Int.(n = Operation_repr.consensus_pass) ->\n {vs with op_count}\n | _ ->\n {\n vs with\n op_count;\n recorded_operations_rev = ophash :: vs.recorded_operations_rev;\n }\n\nlet validate_operation ?(check_signature = true)\n {info; operation_state; block_state} oph\n (packed_operation : packed_operation) =\n let open Lwt_result_syntax in\n let {shell; protocol_data = Operation_data protocol_data} =\n packed_operation\n in\n let validation_pass_opt = Operation.acceptable_pass packed_operation in\n let* block_state =\n check_validation_pass_consistency info block_state validation_pass_opt\n in\n let block_state = record_operation block_state oph validation_pass_opt in\n let operation : _ operation = {shell; protocol_data} in\n match (info.mode, validation_pass_opt) with\n | Partial_validation _, Some n\n when Compare.Int.(n <> Operation_repr.consensus_pass) ->\n (* Do not validate non-consensus operation in [Partial_validation] mode *)\n return {info; operation_state; block_state}\n | Partial_validation _, _ | Mempool, _ | Construction _, _ | Application _, _\n -> (\n match operation.protocol_data.contents with\n | Single (Preendorsement _) ->\n Consensus.validate_preendorsement\n ~check_signature\n info\n operation_state\n block_state\n oph\n operation\n | Single (Endorsement _) ->\n Consensus.validate_endorsement\n ~check_signature\n info\n operation_state\n block_state\n oph\n operation\n | Single (Dal_attestation _) ->\n let open Consensus in\n let* () = check_dal_attestation info operation in\n let*? () =\n check_dal_attestation_conflict operation_state oph operation\n |> wrap_dal_attestation_conflict\n in\n let operation_state =\n add_dal_attestation operation_state oph operation\n in\n return {info; operation_state; block_state}\n | Single (Proposals _) ->\n let open Voting in\n let* () = check_proposals info ~check_signature operation in\n let*? () =\n check_proposals_conflict operation_state oph operation\n |> wrap_proposals_conflict\n in\n let operation_state = add_proposals operation_state oph operation in\n return {info; operation_state; block_state}\n | Single (Ballot _) ->\n let open Voting in\n let* () = check_ballot info ~check_signature operation in\n let*? () =\n check_ballot_conflict operation_state oph operation\n |> wrap_ballot_conflict\n in\n let operation_state = add_ballot operation_state oph operation in\n return {info; operation_state; block_state}\n | Single (Activate_account _) ->\n let open Anonymous in\n let* () = check_activate_account info operation in\n let*? () =\n check_activate_account_conflict operation_state oph operation\n |> wrap_activate_account_conflict operation\n in\n let operation_state =\n add_activate_account operation_state oph operation\n in\n return {info; operation_state; block_state}\n | Single (Double_preendorsement_evidence _) ->\n let open Anonymous in\n let* () = check_double_preendorsement_evidence info operation in\n let*? () =\n check_double_preendorsement_evidence_conflict\n operation_state\n oph\n operation\n |> wrap_denunciation_conflict Preendorsement\n in\n let operation_state =\n add_double_preendorsement_evidence operation_state oph operation\n in\n return {info; operation_state; block_state}\n | Single (Double_endorsement_evidence _) ->\n let open Anonymous in\n let* () = check_double_endorsement_evidence info operation in\n let*? () =\n check_double_endorsement_evidence_conflict\n operation_state\n oph\n operation\n |> wrap_denunciation_conflict Endorsement\n in\n let operation_state =\n add_double_endorsement_evidence operation_state oph operation\n in\n return {info; operation_state; block_state}\n | Single (Double_baking_evidence _) ->\n let open Anonymous in\n let* () = check_double_baking_evidence info operation in\n let*? () =\n check_double_baking_evidence_conflict operation_state oph operation\n |> wrap_denunciation_conflict Block\n in\n let operation_state =\n add_double_baking_evidence operation_state oph operation\n in\n return {info; operation_state; block_state}\n | Single (Drain_delegate _) ->\n let open Anonymous in\n let* () = check_drain_delegate info ~check_signature operation in\n let*? () =\n check_drain_delegate_conflict operation_state oph operation\n |> wrap_drain_delegate_conflict operation\n in\n let operation_state =\n add_drain_delegate operation_state oph operation\n in\n return {info; operation_state; block_state}\n | Single (Seed_nonce_revelation _) ->\n let open Anonymous in\n let* () = check_seed_nonce_revelation info operation in\n let*? () =\n check_seed_nonce_revelation_conflict operation_state oph operation\n |> wrap_seed_nonce_revelation_conflict\n in\n let operation_state =\n add_seed_nonce_revelation operation_state oph operation\n in\n return {info; operation_state; block_state}\n | Single (Vdf_revelation _) ->\n let open Anonymous in\n let* () = check_vdf_revelation info operation in\n let*? () =\n check_vdf_revelation_conflict operation_state oph\n |> wrap_vdf_revelation_conflict\n in\n let operation_state = add_vdf_revelation operation_state oph in\n return {info; operation_state; block_state}\n | Single (Manager_operation _) ->\n Manager.validate_manager_operation\n ~check_signature\n info\n operation_state\n block_state\n oph\n operation\n | Cons (Manager_operation _, _) ->\n Manager.validate_manager_operation\n ~check_signature\n info\n operation_state\n block_state\n oph\n operation\n | Single (Failing_noop _) -> tzfail Validate_errors.Failing_noop_error)\n\nlet are_endorsements_required vi =\n let open Lwt_result_syntax in\n let+ first_level = First_level_of_protocol.get vi.ctxt in\n (* [Comment from Legacy_apply] NB: the first level is the level\n of the migration block. There are no endorsements for this\n block. Therefore the block at the next level cannot contain\n endorsements. *)\n let level_position_in_protocol =\n Raw_level.diff vi.current_level.level first_level\n in\n Compare.Int32.(level_position_in_protocol > 1l)\n\nlet check_endorsement_power vi bs =\n let required = Constants.consensus_threshold vi.ctxt in\n let provided = bs.endorsement_power in\n error_unless\n Compare.Int.(provided >= required)\n (Validate_errors.Block.Not_enough_endorsements {required; provided})\n\nlet finalize_validate_block_header vi vs checkable_payload_hash\n (block_header_contents : Block_header.contents) round fitness =\n let locked_round_evidence =\n Option.map\n (fun (preendorsement_round, preendorsement_count) ->\n Block_header.{preendorsement_round; preendorsement_count})\n vs.locked_round_evidence\n in\n Block_header.finalize_validate_block_header\n ~block_header_contents\n ~round\n ~fitness\n ~checkable_payload_hash\n ~locked_round_evidence\n ~consensus_threshold:(Constants.consensus_threshold vi.ctxt)\n\nlet compute_payload_hash block_state\n (block_header_contents : Block_header.contents) ~predecessor_hash =\n Block_payload.hash\n ~predecessor_hash\n ~payload_round:block_header_contents.payload_round\n (List.rev block_state.recorded_operations_rev)\n\nlet finalize_block {info; block_state; _} =\n let open Lwt_result_syntax in\n match info.mode with\n | Application {fitness; predecessor_hash; block_data_contents; _} ->\n let* are_endorsements_required = are_endorsements_required info in\n let*? () =\n if are_endorsements_required then\n check_endorsement_power info block_state\n else ok_unit\n in\n let block_payload_hash =\n compute_payload_hash block_state block_data_contents ~predecessor_hash\n in\n let round = Fitness.round fitness in\n let*? () =\n finalize_validate_block_header\n info\n block_state\n (Block_header.Expected_payload_hash block_payload_hash)\n block_data_contents\n round\n fitness\n in\n return_unit\n | Partial_validation _ ->\n let* are_endorsements_required = are_endorsements_required info in\n let*? () =\n if are_endorsements_required then\n check_endorsement_power info block_state\n else ok_unit\n in\n return_unit\n | Construction\n {predecessor_round; predecessor_hash; round; block_data_contents; _} ->\n let block_payload_hash =\n compute_payload_hash block_state block_data_contents ~predecessor_hash\n in\n let locked_round_evidence = block_state.locked_round_evidence in\n let checkable_payload_hash =\n match locked_round_evidence with\n | Some _ -> Block_header.Expected_payload_hash block_payload_hash\n | None ->\n (* In full construction, when there is no locked round\n evidence (and thus no preendorsements), the baker cannot\n know the payload hash before selecting the operations. We\n may dismiss checking the initially given\n payload_hash. However, to be valid, the baker must patch\n the resulting block header with the actual payload\n hash. *)\n Block_header.No_check\n in\n let* are_endorsements_required = are_endorsements_required info in\n let*? () =\n if are_endorsements_required then\n check_endorsement_power info block_state\n else ok_unit\n in\n let* fitness =\n let locked_round =\n match locked_round_evidence with\n | None -> None\n | Some (preendorsement_round, _power) -> Some preendorsement_round\n in\n let level = (Level.current info.ctxt).level in\n let*? fitness =\n Fitness.create ~level ~round ~predecessor_round ~locked_round\n in\n return fitness\n in\n let*? () =\n finalize_validate_block_header\n info\n block_state\n checkable_payload_hash\n block_data_contents\n round\n fitness\n in\n return_unit\n | Mempool ->\n (* Nothing to do for the mempool mode*)\n return_unit\n" ;
} ;
{ name = "Mempool_validation" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module implements a mempool structure meant to be used by a\n shell and bakers in order to incrementally accumulate commutative\n operations which could then be safely used to bake a new\n block. These mempool components guarantee a set of properties\n useful for these purposes:\n\n - Every operation contained in a mempool is valid;\n\n - All the mempool's operations can safely be included (and\n applicable) in a block in an arbitrary order which means\n operations commutes. However, to build a valid block with these\n operations:\n\n - Operations must be reorganized with regards to their validation\n passes.\n - Block's operations quota are ignored, it is the baker's\n responsability to ensure that the set of selected operations\n does not exceed gas/size operations quota.\n - The baker must also include the required preendorsements and\n endorsements.\n\n - The merging of two mempools also maintains the aforementioned\n properties.\n\n Mempools do not depend on local data and therefore are\n serializable. This is useful when a node needs to send a mempool\n to another (remote-)process (e.g. the baker).\n*)\n\nopen Alpha_context\n\n(** Mempool type *)\ntype t\n\n(** Validation info type required to validate and add operations to a\n mempool. *)\ntype validation_info\n\n(** Type of the function that may be provided in order to resolve a\n potential conflict when adding an operation to an existing mempool\n or when merging two mempools. This handler may be defined as a\n simple order relation over operations (e.g. prioritize the most\n profitable operations) or an arbitrary one (e.g. prioritize\n operations where the source is a specific manager).\n\n Returning [`Keep] will leave the mempool unchanged and retain the\n [existing_operation] while returning [`Replace] will remove\n [existing_operation] and add [new_operation] instead. *)\ntype conflict_handler =\n existing_operation:Operation_hash.t * packed_operation ->\n new_operation:Operation_hash.t * packed_operation ->\n [`Keep | `Replace]\n\n(** Return type when adding an operation to the mempool *)\ntype add_result =\n | Added\n (** [Added] means that an operation was successfully added to\n the mempool without any conflict. *)\n | Replaced of {removed : Operation_hash.t}\n (** [Replaced {removed}] means that an operation was\n successfully added but there was a conflict with the [removed]\n operation which was removed from the mempool. *)\n | Unchanged\n (** [Unchanged] means that there was a conflict with an existing\n operation which was considered better by the\n [conflict_handler], therefore the new operation is discarded\n and the mempool remains unchanged. *)\n\ntype operation_conflict = Validate_errors.operation_conflict =\n | Operation_conflict of {\n existing : Operation_hash.t;\n new_operation : Operation_hash.t;\n }\n\n(** Error type returned when adding an operation to the mempool fails. *)\ntype add_error =\n | Validation_error of error trace\n (** [Validation_error _] means that the operation is invalid. *)\n | Add_conflict of operation_conflict\n (** [Add_conflict _] means that an operation conflicts with an\n existing one. This error will only be obtained when no\n [conflict_handler] was provided. Moreover, [Validation_error _]\n takes precedence over [Add_conflict _] which implies that\n we have the implicit invariant that the operation would be\n valid if there was no conflict. Therefore, if\n [add_operation] would have to be called again, it would be\n redondant to check the operation's signature. *)\n\n(** Error type returned when the merge of two mempools fails. *)\ntype merge_error =\n | Incompatible_mempool\n (** [Incompatible_mempool _] means that the two mempools are not built\n ontop of the same head and therefore cannot be considered. *)\n | Merge_conflict of operation_conflict\n (** [Merge_conflict _] arises when two mempools contain conflicting\n operations and no [conflict_handler] was provided. *)\n\n(** Mempool encoding *)\nval encoding : t Data_encoding.t\n\n(** Initialize a static [validation_info] and [mempool], required to validate and add\n operations, and an incremental and serializable [mempool]. *)\nval init :\n context ->\n Chain_id.t ->\n predecessor_level:Level.t ->\n predecessor_round:Round.t ->\n predecessor_hash:Block_hash.t ->\n grandparent_round:Round.t ->\n validation_info * t\n\n(** Adds an operation to a [mempool] if and only if it is valid and\n does not conflict with previously added operations.\n\n This function checks the validity of an operation (see\n {!Validate.check_operation}) and tries to add it to the mempool.\n\n If an error occurs during the validation, the result will be a\n [Validation_error <err>]. If a conflict with a previous operation\n exists, the result will be an [Add_conflict] (see\n {!Validate.check_operation_conflict}). Important: no\n [Add_conflict] will be raised if a [conflict_handler] is\n provided (see [add_result]).\n\n If no error is raised the operation is potentially added to the\n [mempool] depending on the [add_result] value. *)\nval add_operation :\n ?check_signature:bool ->\n ?conflict_handler:conflict_handler ->\n validation_info ->\n t ->\n Operation_hash.t * packed_operation ->\n (t * add_result, add_error) result Lwt.t\n\n(** [remove_operation mempool oph] removes the operation [oph] from\n the [mempool]. The [mempool] remains unchanged when [oph] is not\n present in the [mempool] *)\nval remove_operation : t -> Operation_hash.t -> t\n\n(** [merge ?conflict_handler existing_mempool new_mempool] merges [new_mempool]\n {b into} [existing_mempool].\n\n Mempools may only be merged if they are compatible: i.e. both have\n been initialised with the same predecessor block. Otherwise, the\n [Incompatible_mempool] error is returned.\n\n Conflicts between operations from the two mempools can\n occur. Similarly as [add_operation], a [Merge_conflict] error\n may be raised when no [conflict_handler] is provided.\n\n [existing_operation] in [conflict_handler ~existing_operation ~new_operation]\n references operations present in [existing_mempool] while\n [new_operation] will reference operations present in\n [new_mempool]. *)\nval merge :\n ?conflict_handler:conflict_handler -> t -> t -> (t, merge_error) result\n\n(** [operations mempool] returns the map of operations present in\n [mempool]. *)\nval operations : t -> packed_operation Operation_hash.Map.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\nopen Validate\n\ntype t = {\n predecessor_hash : Block_hash.t;\n operation_state : operation_conflict_state;\n operations : packed_operation Operation_hash.Map.t;\n}\n\ntype validation_info = Validate.info\n\ntype add_result = Added | Replaced of {removed : Operation_hash.t} | Unchanged\n\ntype operation_conflict = Validate_errors.operation_conflict =\n | Operation_conflict of {\n existing : Operation_hash.t;\n new_operation : Operation_hash.t;\n }\n\ntype add_error =\n | Validation_error of error trace\n | Add_conflict of operation_conflict\n\ntype merge_error = Incompatible_mempool | Merge_conflict of operation_conflict\n\nlet encoding : t Data_encoding.t =\n let open Data_encoding in\n def \"mempool\"\n @@ conv\n (fun {predecessor_hash; operation_state; operations} ->\n (predecessor_hash, operation_state, operations))\n (fun (predecessor_hash, operation_state, operations) ->\n {predecessor_hash; operation_state; operations})\n @@ obj3\n (req \"predecessor_hash\" Block_hash.encoding)\n (req \"operation_state\" Validate.operation_conflict_state_encoding)\n (req\n \"operations\"\n (Operation_hash.Map.encoding\n (dynamic_size ~kind:`Uint30 Operation.encoding)))\n\nlet init ctxt chain_id ~predecessor_level ~predecessor_round ~predecessor_hash\n ~grandparent_round : validation_info * t =\n let {info; operation_state; _} =\n begin_partial_construction\n ctxt\n chain_id\n ~predecessor_level\n ~predecessor_round\n ~grandparent_round\n in\n ( info,\n {predecessor_hash; operation_state; operations = Operation_hash.Map.empty}\n )\n\ntype conflict_handler =\n existing_operation:Operation_hash.t * packed_operation ->\n new_operation:Operation_hash.t * packed_operation ->\n [`Keep | `Replace]\n\nlet remove_operation mempool oph =\n match Operation_hash.Map.find_opt oph mempool.operations with\n | None -> mempool\n | Some {shell; protocol_data = Operation_data protocol_data} ->\n let operations = Operation_hash.Map.remove oph mempool.operations in\n let operation_state =\n remove_operation mempool.operation_state {shell; protocol_data}\n in\n {mempool with operations; operation_state}\n\nlet add_operation ?(check_signature = true)\n ?(conflict_handler : conflict_handler option) info mempool\n (oph, (packed_op : packed_operation)) :\n (t * add_result, add_error) result Lwt.t =\n let open Lwt_syntax in\n let {shell; protocol_data = Operation_data protocol_data} = packed_op in\n let operation : _ Alpha_context.operation = {shell; protocol_data} in\n let* validate_result = check_operation ~check_signature info operation in\n match validate_result with\n | Error err -> Lwt.return_error (Validation_error err)\n | Ok () -> (\n match check_operation_conflict mempool.operation_state oph operation with\n | Ok () ->\n let operation_state =\n add_valid_operation mempool.operation_state oph operation\n in\n let operations =\n Operation_hash.Map.add oph packed_op mempool.operations\n in\n let result = Added in\n Lwt.return_ok ({mempool with operation_state; operations}, result)\n | Error\n (Validate_errors.Operation_conflict\n {existing; new_operation = new_oph} as x) -> (\n match conflict_handler with\n | Some handler -> (\n let new_operation = (new_oph, packed_op) in\n let existing_operation =\n match\n Operation_hash.Map.find_opt existing mempool.operations\n with\n | None -> assert false\n | Some op -> (existing, op)\n in\n match handler ~existing_operation ~new_operation with\n | `Keep -> Lwt.return_ok (mempool, Unchanged)\n | `Replace ->\n let mempool = remove_operation mempool existing in\n let operation_state =\n add_valid_operation\n mempool.operation_state\n new_oph\n operation\n in\n let operations =\n Operation_hash.Map.add oph packed_op mempool.operations\n in\n Lwt.return_ok\n ( {mempool with operations; operation_state},\n Replaced {removed = existing} ))\n | None -> Lwt.return_error (Add_conflict x)))\n\nlet merge ?conflict_handler existing_mempool new_mempool =\n if\n Block_hash.(\n existing_mempool.predecessor_hash <> new_mempool.predecessor_hash)\n then Error Incompatible_mempool\n else\n let open Result_syntax in\n let unique_new_operations =\n (* only retain unique operations that are in new_mempool *)\n Operation_hash.Map.(\n merge\n (fun _ l r ->\n match (l, r) with\n | None, Some r -> Some r\n | Some _, None -> None\n | Some _, Some _ -> None\n | None, None -> None)\n existing_mempool.operations\n new_mempool.operations)\n in\n let unopt_assert = function None -> assert false | Some o -> o in\n let handle_conflict new_operation_content conflict =\n match (conflict, conflict_handler) with\n | Ok (), _ -> Ok `Add_new\n | Error conflict, None -> Error (Merge_conflict conflict)\n | ( Error (Operation_conflict {existing; new_operation}),\n Some (f : conflict_handler) ) -> (\n (* New operations can only conflict with operations\n already present in the existing mempool. *)\n let existing_operation_content =\n Operation_hash.Map.find_opt existing existing_mempool.operations\n |> unopt_assert\n in\n match\n f\n ~existing_operation:(existing, existing_operation_content)\n ~new_operation:(new_operation, new_operation_content)\n with\n | `Keep -> Ok `Do_nothing\n | `Replace -> Ok (`Replace existing))\n in\n Operation_hash.Map.fold_e\n (fun roph packed_right_op mempool_acc ->\n let {shell; protocol_data = Operation_data protocol_data} =\n packed_right_op\n in\n let right_op = ({shell; protocol_data} : _ operation) in\n let* conflict =\n check_operation_conflict mempool_acc.operation_state roph right_op\n |> handle_conflict packed_right_op\n in\n match conflict with\n | `Do_nothing -> return mempool_acc\n | `Add_new ->\n let operation_state =\n add_valid_operation mempool_acc.operation_state roph right_op\n in\n let operations =\n Operation_hash.Map.add roph packed_right_op mempool_acc.operations\n in\n return {mempool_acc with operation_state; operations}\n | `Replace loph ->\n let mempool_acc = remove_operation mempool_acc loph in\n let operation_state =\n add_valid_operation mempool_acc.operation_state roph right_op\n in\n let operations =\n Operation_hash.Map.add roph packed_right_op mempool_acc.operations\n in\n return {mempool_acc with operation_state; operations})\n unique_new_operations\n existing_mempool\n\nlet operations mempool = mempool.operations\n" ;
} ;
{ name = "Apply" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020-2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module supports advancing the ledger state by applying [operation]s.\n\n Each operation application takes and returns an [application_state], representing\n the old and new state, respectively.\n\n The [Main] module provides wrappers for the functionality in this module,\n satisfying the Protocol signature.\n *)\n\nopen Alpha_context\n\ntype error +=\n | Internal_operation_replay of\n Apply_internal_results.packed_internal_operation\n | Tx_rollup_feature_disabled\n | Tx_rollup_invalid_transaction_ticket_amount\n | Sc_rollup_feature_disabled\n | Empty_transaction of Contract.t\n\ntype mode =\n | Application of {\n block_header : Block_header.t;\n fitness : Fitness.t;\n payload_producer : Consensus_key.t;\n block_producer : Consensus_key.t;\n predecessor_level : Level.t;\n predecessor_round : Round.t;\n }\n | Full_construction of {\n block_data_contents : Block_header.contents;\n predecessor_hash : Block_hash.t;\n payload_producer : Consensus_key.t;\n block_producer : Consensus_key.t;\n round : Round.t;\n predecessor_level : Level.t;\n predecessor_round : Round.t;\n }\n | Partial_construction of {\n predecessor_level : Raw_level.t;\n predecessor_fitness : Fitness.raw;\n } (** This mode is mainly intended to be used by a mempool. *)\n\ntype application_state = {\n ctxt : context;\n chain_id : Chain_id.t;\n mode : mode;\n op_count : int;\n migration_balance_updates : Receipt.balance_updates;\n liquidity_baking_toggle_ema : Liquidity_baking.Toggle_EMA.t;\n implicit_operations_results :\n Apply_results.packed_successful_manager_operation_result list;\n}\n\n(** Initialize an {!application_state} for the application of an\n existing block. *)\nval begin_application :\n context ->\n Chain_id.t ->\n migration_balance_updates:Receipt.balance_updates ->\n migration_operation_results:Migration.origination_result list ->\n predecessor_fitness:Fitness.raw ->\n Block_header.t ->\n application_state tzresult Lwt.t\n\n(** Initialize an {!application_state} for the construction of a\n fresh block. *)\nval begin_full_construction :\n context ->\n Chain_id.t ->\n migration_balance_updates:Receipt.balance_updates ->\n migration_operation_results:Migration.origination_result list ->\n predecessor_timestamp:Time.t ->\n predecessor_level:Level.t ->\n predecessor_round:Round.t ->\n predecessor_hash:Block_hash.t ->\n timestamp:Time.t ->\n Block_header.contents ->\n application_state tzresult Lwt.t\n\n(** Initialize an {!application_state} for the partial construction of\n a block. This is similar to construction but less information is\n required as this will not yield a final valid block. *)\nval begin_partial_construction :\n context ->\n Chain_id.t ->\n migration_balance_updates:Receipt.balance_updates ->\n migration_operation_results:Migration.origination_result list ->\n predecessor_level:Raw_level.t ->\n predecessor_hash:Block_hash.t ->\n predecessor_fitness:Fitness.raw ->\n application_state tzresult Lwt.t\n\n(** Apply an operation, i.e. update the given context in accordance\n with the operation's semantic (or return an error if the operation\n is not applicable).\n\n For non-manager operations, the application of a validated\n operation should always fully succeed.\n\n For manager operations, the application has two stages. The first\n stage consists in updating the context to:\n\n - take the fees;\n\n - increment the account's counter;\n\n - decrease of the available block gas by operation's [gas_limit].\n\n These updates are mandatory. In particular, taking the fees is\n critically important. The {!Validate} module is responsible for\n ensuring that the operation is solvable, i.e. that fees can be\n taken, i.e. that the first stage of manager operation application\n cannot fail. If this stage fails nevertheless, the function returns\n an error.\n\n The second stage of this function (still in the case of a manager\n operation) consists in applying all the other effects, in\n accordance with the semantic of the operation's kind.\n\n An error may happen during this second phase: in that case, the\n function returns the context obtained at the end of the first\n stage, and metadata that contain the error. This means that the\n operation has no other effects than those described above during\n the first phase. *)\nval apply_operation :\n application_state ->\n Operation_hash.t ->\n packed_operation ->\n (application_state * Apply_results.packed_operation_metadata) tzresult Lwt.t\n\n(** Finalize the application of a block depending on its mode. *)\nval finalize_block :\n application_state ->\n Block_header.shell_header option ->\n (Updater.validation_result * Apply_results.block_metadata) tzresult Lwt.t\n\n(** [value_of_key ctxt k] builds a value identified by key [k]\n so that it can be put into the cache. *)\nval value_of_key :\n context -> Context.Cache.key -> Context.Cache.value tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2019-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* Copyright (c) 2022 Trili Tech, <contact@trili.tech> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Tezos Protocol Implementation - Main Entry Points *)\n\nopen Alpha_context\n\ntype error +=\n | Not_enough_endorsements of {required : int; provided : int}\n | Faulty_validation_wrong_slot\n | Set_deposits_limit_on_unregistered_delegate of Signature.Public_key_hash.t\n | Set_deposits_limit_too_high of {limit : Tez.t; max_limit : Tez.t}\n | Error_while_taking_fees\n | Update_consensus_key_on_unregistered_delegate of Signature.Public_key_hash.t\n | Empty_transaction of Contract.t\n | Non_empty_transaction_from of Destination.t\n | Tx_rollup_feature_disabled\n | Tx_rollup_invalid_transaction_ticket_amount\n | Sc_rollup_feature_disabled\n | Internal_operation_replay of\n Apply_internal_results.packed_internal_operation\n | Multiple_revelation\n | Zero_frozen_deposits of Signature.Public_key_hash.t\n | Invalid_transfer_to_sc_rollup\n | Invalid_source of Destination.t\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"operation.not_enough_endorsements\"\n ~title:\"Not enough endorsements\"\n ~description:\n \"The block being validated does not include the required minimum number \\\n of endorsements.\"\n ~pp:(fun ppf (required, provided) ->\n Format.fprintf\n ppf\n \"Wrong number of endorsements (%i), at least %i are expected\"\n provided\n required)\n Data_encoding.(obj2 (req \"required\" int31) (req \"provided\" int31))\n (function\n | Not_enough_endorsements {required; provided} -> Some (required, provided)\n | _ -> None)\n (fun (required, provided) -> Not_enough_endorsements {required; provided}) ;\n let description =\n \"The consensus operation uses an invalid slot. This error should not \\\n happen: the operation validation should have failed earlier.\"\n in\n register_error_kind\n `Permanent\n ~id:\"operation.faulty_validation_wrong_slot\"\n ~title:\"Faulty validation (wrong slot for consensus operation)\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.empty\n (function Faulty_validation_wrong_slot -> Some () | _ -> None)\n (fun () -> Faulty_validation_wrong_slot) ;\n register_error_kind\n `Temporary\n ~id:\"operation.set_deposits_limit_on_unregistered_delegate\"\n ~title:\"Set deposits limit on an unregistered delegate\"\n ~description:\"Cannot set deposits limit on an unregistered delegate.\"\n ~pp:(fun ppf c ->\n Format.fprintf\n ppf\n \"Cannot set a deposits limit on the unregistered delegate %a.\"\n Signature.Public_key_hash.pp\n c)\n Data_encoding.(obj1 (req \"delegate\" Signature.Public_key_hash.encoding))\n (function\n | Set_deposits_limit_on_unregistered_delegate c -> Some c | _ -> None)\n (fun c -> Set_deposits_limit_on_unregistered_delegate c) ;\n register_error_kind\n `Permanent\n ~id:\"operation.set_deposits_limit_too_high\"\n ~title:\"Set deposits limit to a too high value\"\n ~description:\n \"Cannot set deposits limit such that the active stake overflows.\"\n ~pp:(fun ppf (limit, max_limit) ->\n Format.fprintf\n ppf\n \"Cannot set deposits limit to %a as it is higher the allowed maximum \\\n %a.\"\n Tez.pp\n limit\n Tez.pp\n max_limit)\n Data_encoding.(\n obj2 (req \"limit\" Tez.encoding) (req \"max_limit\" Tez.encoding))\n (function\n | Set_deposits_limit_too_high {limit; max_limit} -> Some (limit, max_limit)\n | _ -> None)\n (fun (limit, max_limit) -> Set_deposits_limit_too_high {limit; max_limit}) ;\n\n let error_while_taking_fees_description =\n \"There was an error while taking the fees, which should not happen and \\\n means that the operation's validation was faulty.\"\n in\n register_error_kind\n `Permanent\n ~id:\"operation.error_while_taking_fees\"\n ~title:\"Error while taking the fees of a manager operation\"\n ~description:error_while_taking_fees_description\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"%s\" error_while_taking_fees_description)\n Data_encoding.unit\n (function Error_while_taking_fees -> Some () | _ -> None)\n (fun () -> Error_while_taking_fees) ;\n\n register_error_kind\n `Temporary\n ~id:\"operation.update_consensus_key_on_unregistered_delegate\"\n ~title:\"Update consensus key on an unregistered delegate\"\n ~description:\"Cannot update consensus key an unregistered delegate.\"\n ~pp:(fun ppf c ->\n Format.fprintf\n ppf\n \"Cannot update the consensus key on the unregistered delegate %a.\"\n Signature.Public_key_hash.pp\n c)\n Data_encoding.(obj1 (req \"delegate\" Signature.Public_key_hash.encoding))\n (function\n | Update_consensus_key_on_unregistered_delegate c -> Some c | _ -> None)\n (fun c -> Update_consensus_key_on_unregistered_delegate c) ;\n register_error_kind\n `Branch\n ~id:\"contract.empty_transaction\"\n ~title:\"Empty transaction\"\n ~description:\"Forbidden to credit 0\234\156\169 to a contract without code.\"\n ~pp:(fun ppf contract ->\n Format.fprintf\n ppf\n \"Transactions of 0\234\156\169 towards a contract without code are forbidden (%a).\"\n Contract.pp\n contract)\n Data_encoding.(obj1 (req \"contract\" Contract.encoding))\n (function Empty_transaction c -> Some c | _ -> None)\n (fun c -> Empty_transaction c) ;\n register_error_kind\n `Branch\n ~id:\"contract.non_empty_transaction_from_source\"\n ~title:\"Unexpected non-empty transaction\"\n ~description:\"This address cannot initiate non-empty transactions\"\n ~pp:(fun ppf contract ->\n Format.fprintf\n ppf\n \"%a does not have a balance and cannot initiate non-empty transactions\"\n Destination.pp\n contract)\n Data_encoding.(obj1 (req \"source\" Destination.encoding))\n (function Non_empty_transaction_from c -> Some c | _ -> None)\n (fun c -> Non_empty_transaction_from c) ;\n\n register_error_kind\n `Permanent\n ~id:\"operation.tx_rollup_is_disabled\"\n ~title:\"Tx rollup is disabled\"\n ~description:\"Cannot originate a tx rollup as it is disabled.\"\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"Cannot apply a tx rollup operation as it is disabled.\")\n Data_encoding.unit\n (function Tx_rollup_feature_disabled -> Some () | _ -> None)\n (fun () -> Tx_rollup_feature_disabled) ;\n\n register_error_kind\n `Permanent\n ~id:\"operation.tx_rollup_invalid_transaction_ticket_amount\"\n ~title:\"Amount of transferred ticket is too high\"\n ~description:\n \"The ticket amount of a rollup transaction must fit in a signed 64-bit \\\n integer.\"\n ~pp:(fun ppf () ->\n Format.fprintf ppf \"Amount of transferred ticket is too high.\")\n Data_encoding.unit\n (function\n | Tx_rollup_invalid_transaction_ticket_amount -> Some () | _ -> None)\n (fun () -> Tx_rollup_invalid_transaction_ticket_amount) ;\n\n let description = \"Smart rollups are disabled.\" in\n register_error_kind\n `Permanent\n ~id:\"operation.smart_rollup_disabled\"\n ~title:\"Smart rollups are disabled\"\n ~description\n ~pp:(fun ppf () -> Format.fprintf ppf \"%s\" description)\n Data_encoding.unit\n (function Sc_rollup_feature_disabled -> Some () | _ -> None)\n (fun () -> Sc_rollup_feature_disabled) ;\n\n register_error_kind\n `Permanent\n ~id:\"internal_operation_replay\"\n ~title:\"Internal operation replay\"\n ~description:\"An internal operation was emitted twice by a script\"\n ~pp:(fun ppf (Apply_internal_results.Internal_operation {nonce; _}) ->\n Format.fprintf\n ppf\n \"Internal operation %d was emitted twice by a script\"\n nonce)\n Apply_internal_results.internal_operation_encoding\n (function Internal_operation_replay op -> Some op | _ -> None)\n (fun op -> Internal_operation_replay op) ;\n register_error_kind\n `Permanent\n ~id:\"block.multiple_revelation\"\n ~title:\"Multiple revelations were included in a manager operation\"\n ~description:\n \"A manager operation should not contain more than one revelation\"\n ~pp:(fun ppf () ->\n Format.fprintf\n ppf\n \"Multiple revelations were included in a manager operation\")\n Data_encoding.empty\n (function Multiple_revelation -> Some () | _ -> None)\n (fun () -> Multiple_revelation) ;\n register_error_kind\n `Permanent\n ~id:\"delegate.zero_frozen_deposits\"\n ~title:\"Zero frozen deposits\"\n ~description:\"The delegate has zero frozen deposits.\"\n ~pp:(fun ppf delegate ->\n Format.fprintf\n ppf\n \"Delegate %a has zero frozen deposits; it is not allowed to \\\n bake/preendorse/endorse.\"\n Signature.Public_key_hash.pp\n delegate)\n Data_encoding.(obj1 (req \"delegate\" Signature.Public_key_hash.encoding))\n (function Zero_frozen_deposits delegate -> Some delegate | _ -> None)\n (fun delegate -> Zero_frozen_deposits delegate) ;\n register_error_kind\n `Permanent\n ~id:\"operations.invalid_transfer_to_smart_rollup_from_implicit_account\"\n ~title:\"Invalid transfer to smart rollup\"\n ~description:\"Invalid transfer to smart rollup from implicit account\"\n ~pp:(fun ppf () ->\n Format.fprintf\n ppf\n \"Invalid source for transfer operation to smart rollup. Only \\\n originated accounts are allowed.\")\n Data_encoding.empty\n (function Invalid_transfer_to_sc_rollup -> Some () | _ -> None)\n (fun () -> Invalid_transfer_to_sc_rollup) ;\n register_error_kind\n `Permanent\n ~id:\"operations.invalid_source\"\n ~title:\"Invalid source for an internal operation\"\n ~description:\n \"Invalid source for an internal operation restricted to implicit and \\\n originated accounts.\"\n ~pp:(fun ppf c ->\n Format.fprintf\n ppf\n \"Invalid source (%a) for this internal operation. Only implicit and \\\n originated accounts are allowed\"\n Destination.pp\n c)\n Data_encoding.(obj1 (req \"contract\" Destination.encoding))\n (function Invalid_source c -> Some c | _ -> None)\n (fun c -> Invalid_source c)\n\nopen Apply_results\nopen Apply_operation_result\nopen Apply_internal_results\n\nlet assert_tx_rollup_feature_enabled ctxt =\n let open Result_syntax in\n let level = (Level.current ctxt).level in\n let* sunset = Raw_level.of_int32 @@ Constants.tx_rollup_sunset_level ctxt in\n let* () = error_when Raw_level.(sunset <= level) Tx_rollup_feature_disabled in\n error_unless (Constants.tx_rollup_enable ctxt) Tx_rollup_feature_disabled\n\nlet assert_sc_rollup_feature_enabled ctxt =\n error_unless (Constants.sc_rollup_enable ctxt) Sc_rollup_feature_disabled\n\nlet update_script_storage_and_ticket_balances ctxt ~self_contract storage\n lazy_storage_diff ticket_diffs operations =\n Contract.update_script_storage ctxt self_contract storage lazy_storage_diff\n >>=? fun ctxt ->\n let self_contract = Contract.Originated self_contract in\n Ticket_accounting.update_ticket_balances\n ctxt\n ~self_contract\n ~ticket_diffs\n operations\n\nlet apply_delegation ~ctxt ~source ~delegate ~before_operation =\n Contract.Delegate.set ctxt source delegate >|=? fun ctxt ->\n (ctxt, Gas.consumed ~since:before_operation ~until:ctxt, [])\n\ntype 'loc execution_arg =\n | Typed_arg : 'loc * ('a, _) Script_typed_ir.ty * 'a -> 'loc execution_arg\n | Untyped_arg : Script.expr -> _ execution_arg\n\nlet apply_transaction_to_implicit ~ctxt ~source ~amount ~pkh ~before_operation =\n let contract = Contract.Implicit pkh in\n (* Transfers of zero to implicit accounts are forbidden. *)\n error_when Tez.(amount = zero) (Empty_transaction contract) >>?= fun () ->\n (* If the implicit contract is not yet allocated at this point then\n the next transfer of tokens will allocate it. *)\n Contract.allocated ctxt contract >>= fun already_allocated ->\n Token.transfer ctxt (`Contract source) (`Contract contract) amount\n >>=? fun (ctxt, balance_updates) ->\n let result =\n Transaction_to_contract_result\n {\n storage = None;\n lazy_storage_diff = None;\n balance_updates;\n ticket_receipt = [];\n originated_contracts = [];\n consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;\n storage_size = Z.zero;\n paid_storage_size_diff = Z.zero;\n allocated_destination_contract = not already_allocated;\n }\n in\n return (ctxt, result, [])\n\nlet transfer_from_any_address ctxt source destination amount =\n match source with\n | Destination.Contract source ->\n Token.transfer ctxt (`Contract source) (`Contract destination) amount\n | Destination.Sc_rollup _ | Destination.Tx_rollup _ | Destination.Zk_rollup _\n ->\n (* We do not allow transferring tez from rollups to other contracts. *)\n error_unless Tez.(amount = zero) (Non_empty_transaction_from source)\n >>?= fun () -> return (ctxt, [])\n\nlet apply_transaction_to_implicit_with_ticket ~source ~destination ~ty ~ticket\n ~amount ~before_operation ctxt =\n let destination = Contract.Implicit destination in\n Contract.allocated ctxt destination >>= fun already_allocated ->\n let ex_token, ticket_amount =\n Ticket_scanner.ex_token_and_amount_of_ex_ticket\n @@ Ticket_scanner.Ex_ticket (ty, ticket)\n in\n Ticket_token_unparser.unparse ctxt ex_token >>=? fun (ticket_token, ctxt) ->\n transfer_from_any_address ctxt source destination amount\n >>=? fun (ctxt, balance_updates) ->\n let ticket_receipt =\n Ticket_receipt.\n [\n {\n ticket_token;\n updates =\n [\n {\n account = Destination.Contract destination;\n amount = Script_int.(to_zint (ticket_amount :> n num));\n };\n ];\n };\n ]\n in\n return\n ( ctxt,\n Transaction_to_contract_result\n {\n storage = None;\n lazy_storage_diff = None;\n balance_updates;\n ticket_receipt;\n originated_contracts = [];\n consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;\n storage_size = Z.zero;\n paid_storage_size_diff = Z.zero;\n allocated_destination_contract = not already_allocated;\n },\n [] )\n\nlet apply_transaction_to_smart_contract ~ctxt ~source ~contract_hash ~amount\n ~entrypoint ~before_operation ~payer ~chain_id ~internal ~parameter =\n let contract = Contract.Originated contract_hash in\n (* Since the contract is originated, nothing will be allocated or this\n transfer of tokens will fail. [Token.transfer] will succeed even on\n non-existing contracts, if the amount is zero. Then if the destination\n does not exist, [Script_cache.find] will signal that by returning [None]\n and we'll fail.\n *)\n transfer_from_any_address ctxt source contract amount\n >>=? fun (ctxt, balance_updates) ->\n Script_cache.find ctxt contract_hash >>=? fun (ctxt, cache_key, script) ->\n match script with\n | None -> tzfail (Contract.Non_existing_contract contract)\n | Some (script, script_ir) ->\n (* Token.transfer which is being called before already loads this value into\n the Irmin cache, so no need to burn gas for it. *)\n Contract.get_balance ctxt contract >>=? fun balance ->\n let now = Script_timestamp.now ctxt in\n let level =\n (Level.current ctxt).level |> Raw_level.to_int32 |> Script_int.of_int32\n |> Script_int.abs\n in\n let step_constants =\n let open Script_interpreter in\n {\n source;\n payer;\n self = contract_hash;\n amount;\n chain_id;\n balance;\n now;\n level;\n }\n in\n let execute =\n match parameter with\n | Untyped_arg parameter -> Script_interpreter.execute ~parameter\n | Typed_arg (location, parameter_ty, parameter) ->\n Script_interpreter.execute_with_typed_parameter\n ~location\n ~parameter_ty\n ~parameter\n in\n let cached_script = Some script_ir in\n execute\n ctxt\n ~cached_script\n Optimized\n step_constants\n ~script\n ~entrypoint\n ~internal\n >>=? fun ( {\n script = updated_cached_script;\n code_size = updated_size;\n storage;\n lazy_storage_diff;\n operations;\n ticket_diffs;\n ticket_receipt;\n },\n ctxt ) ->\n update_script_storage_and_ticket_balances\n ctxt\n ~self_contract:contract_hash\n storage\n lazy_storage_diff\n ticket_diffs\n operations\n >>=? fun (ticket_table_size_diff, ctxt) ->\n Ticket_balance.adjust_storage_space\n ctxt\n ~storage_diff:ticket_table_size_diff\n >>=? fun (ticket_paid_storage_diff, ctxt) ->\n Fees.record_paid_storage_space ctxt contract_hash\n >>=? fun (ctxt, new_size, contract_paid_storage_size_diff) ->\n Contract.originated_from_current_nonce ~since:before_operation ~until:ctxt\n >>=? fun originated_contracts ->\n Lwt.return\n ( Script_cache.update\n ctxt\n cache_key\n ( {script with storage = Script.lazy_expr storage},\n updated_cached_script )\n updated_size\n >|? fun ctxt ->\n let result =\n Transaction_to_contract_result\n {\n storage = Some storage;\n lazy_storage_diff;\n balance_updates;\n ticket_receipt;\n originated_contracts;\n consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;\n storage_size = new_size;\n paid_storage_size_diff =\n Z.add contract_paid_storage_size_diff ticket_paid_storage_diff;\n allocated_destination_contract = false;\n }\n in\n (ctxt, result, operations) )\n\nlet apply_transaction_to_tx_rollup ~ctxt ~parameters_ty ~parameters ~payer\n ~dst_rollup ~since =\n assert_tx_rollup_feature_enabled ctxt >>?= fun () ->\n (* If the ticket deposit fails on L2 for some reason\n (e.g. [Balance_overflow] in the recipient), then it is\n returned to [payer]. As [payer] is implicit, it cannot own\n tickets directly. Therefore, erroneous deposits are\n returned using the L2 withdrawal mechanism: a failing\n deposit emits a withdrawal that can be executed by\n [payer]. *)\n let Tx_rollup_parameters.{ex_ticket; l2_destination} =\n Tx_rollup_parameters.get_deposit_parameters parameters_ty parameters\n in\n Ticket_scanner.ex_ticket_size ctxt ex_ticket >>=? fun (ticket_size, ctxt) ->\n let limit = Constants.tx_rollup_max_ticket_payload_size ctxt in\n fail_when\n Saturation_repr.(ticket_size >! limit)\n (Tx_rollup_errors_repr.Ticket_payload_size_limit_exceeded\n {payload_size = ticket_size; limit})\n >>=? fun () ->\n let ex_token, ticket_amount =\n Ticket_scanner.ex_token_and_amount_of_ex_ticket ex_ticket\n in\n Ticket_balance_key.of_ex_token ctxt ~owner:(Tx_rollup dst_rollup) ex_token\n >>=? fun (ticket_hash, ctxt) ->\n Option.value_e\n ~error:\n (Error_monad.trace_of_error Tx_rollup_invalid_transaction_ticket_amount)\n (Option.bind\n (Script_int.to_int64 (ticket_amount :> Script_int.n Script_int.num))\n Tx_rollup_l2_qty.of_int64)\n >>?= fun ticket_amount ->\n error_when\n Tx_rollup_l2_qty.(ticket_amount <= zero)\n Script_tc_errors.Forbidden_zero_ticket_quantity\n >>?= fun () ->\n let deposit, message_size =\n Tx_rollup_message.make_deposit\n payer\n l2_destination\n ticket_hash\n ticket_amount\n in\n Tx_rollup_state.get ctxt dst_rollup >>=? fun (ctxt, state) ->\n Tx_rollup_state.burn_cost ~limit:None state message_size >>?= fun cost ->\n Token.transfer ctxt (`Contract (Contract.Implicit payer)) `Burned cost\n >>=? fun (ctxt, balance_updates) ->\n Tx_rollup_inbox.append_message ctxt dst_rollup state deposit\n >>=? fun (ctxt, state, paid_storage_size_diff) ->\n Tx_rollup_state.update ctxt dst_rollup state >>=? fun ctxt ->\n let result =\n ITransaction_result\n (Transaction_to_tx_rollup_result\n {\n balance_updates;\n consumed_gas = Gas.consumed ~since ~until:ctxt;\n ticket_hash;\n paid_storage_size_diff;\n })\n in\n return (ctxt, result, [])\n\nlet apply_origination ~ctxt ~storage_type ~storage ~unparsed_code\n ~contract:contract_hash ~delegate ~source ~credit ~before_operation =\n Script_ir_translator.collect_lazy_storage ctxt storage_type storage\n >>?= fun (to_duplicate, ctxt) ->\n let to_update = Script_ir_translator.no_lazy_storage_id in\n Script_ir_translator.extract_lazy_storage_diff\n ctxt\n Optimized\n storage_type\n storage\n ~to_duplicate\n ~to_update\n ~temporary:false\n >>=? fun (storage, lazy_storage_diff, ctxt) ->\n Script_ir_translator.unparse_data ctxt Optimized storage_type storage\n >>=? fun (storage, ctxt) ->\n let storage = Script.lazy_expr storage in\n (* Normalize code to avoid #843 *)\n Script_ir_translator.unparse_code\n ctxt\n Optimized\n (Micheline.root unparsed_code)\n >>=? fun (code, ctxt) ->\n let code = Script.lazy_expr code in\n let script = {Script.code; storage} in\n Contract.raw_originate\n ctxt\n ~prepaid_bootstrap_storage:false\n contract_hash\n ~script:(script, lazy_storage_diff)\n >>=? fun ctxt ->\n let contract = Contract.Originated contract_hash in\n (match delegate with\n | None -> return ctxt\n | Some delegate -> Contract.Delegate.init ctxt contract delegate)\n >>=? fun ctxt ->\n Token.transfer ctxt (`Contract source) (`Contract contract) credit\n >>=? fun (ctxt, balance_updates) ->\n Fees.record_paid_storage_space ctxt contract_hash\n >|=? fun (ctxt, size, paid_storage_size_diff) ->\n let result =\n {\n lazy_storage_diff;\n balance_updates;\n originated_contracts = [contract_hash];\n consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;\n storage_size = size;\n paid_storage_size_diff;\n }\n in\n (ctxt, result, [])\n\n(**\n\n Retrieving the source code of a contract from its address is costly\n because it requires I/Os. For this reason, we put the corresponding\n Micheline expression in the cache.\n\n Elaborating a Micheline node into the well-typed script abstract\n syntax tree is also a costly operation. The result of this operation\n is cached as well.\n\n*)\n\nlet assert_source_is_contract = function\n | Destination.Contract source -> ok source\n | source -> error (Invalid_source source)\n\nlet apply_internal_operation_contents :\n type kind.\n context ->\n payer:public_key_hash ->\n source:Destination.t ->\n chain_id:Chain_id.t ->\n kind Script_typed_ir.internal_operation_contents ->\n (context\n * kind successful_internal_operation_result\n * Script_typed_ir.packed_internal_operation list)\n tzresult\n Lwt.t =\n fun ctxt_before_op ~payer ~source ~chain_id operation ->\n Destination.must_exist ctxt_before_op source >>=? fun ctxt ->\n Gas.consume ctxt Michelson_v1_gas.Cost_of.manager_operation >>?= fun ctxt ->\n (* Note that [ctxt_before_op] will be used again later to compute\n gas consumption and originations for the operation result (by\n comparing it with the [ctxt] we will have at the end of the\n application). *)\n match operation with\n | Transaction_to_implicit {destination = pkh; amount} ->\n assert_source_is_contract source >>?= fun source ->\n apply_transaction_to_implicit\n ~ctxt\n ~source\n ~amount\n ~pkh\n ~before_operation:ctxt_before_op\n >|=? fun (ctxt, res, ops) ->\n ( ctxt,\n (ITransaction_result res : kind successful_internal_operation_result),\n ops )\n | Transaction_to_implicit_with_ticket\n {\n destination;\n ticket_ty = Script_typed_ir.Ticket_t (ty, _ty_metadata);\n ticket;\n amount;\n unparsed_ticket = _;\n } ->\n apply_transaction_to_implicit_with_ticket\n ~source\n ~destination\n ~ty\n ~ticket\n ~amount\n ~before_operation:ctxt_before_op\n ctxt\n >|=? fun (ctxt, res, ops) ->\n ( ctxt,\n (ITransaction_result res : kind successful_internal_operation_result),\n ops )\n | Transaction_to_smart_contract\n {\n amount;\n destination = contract_hash;\n entrypoint;\n location;\n parameters_ty;\n parameters = typed_parameters;\n unparsed_parameters = _;\n } ->\n apply_transaction_to_smart_contract\n ~ctxt\n ~source\n ~contract_hash\n ~amount\n ~entrypoint\n ~before_operation:ctxt_before_op\n ~payer\n ~chain_id\n ~internal:true\n ~parameter:(Typed_arg (location, parameters_ty, typed_parameters))\n >|=? fun (ctxt, res, ops) -> (ctxt, ITransaction_result res, ops)\n | Transaction_to_tx_rollup\n {destination; unparsed_parameters = _; parameters_ty; parameters} ->\n apply_transaction_to_tx_rollup\n ~ctxt\n ~parameters_ty\n ~parameters\n ~payer\n ~dst_rollup:destination\n ~since:ctxt_before_op\n | Transaction_to_sc_rollup\n {\n destination;\n entrypoint = _;\n parameters_ty;\n parameters;\n unparsed_parameters = payload;\n } ->\n assert_sc_rollup_feature_enabled ctxt >>?= fun () ->\n (* TODO: #3242\n We could rather change the type of [source] in\n {!Script_type_ir.internal_operation}. Only originated accounts should\n be allowed anyway for internal operations.\n *)\n (match source with\n | Destination.Contract (Originated hash) -> ok hash\n | _ -> error Invalid_transfer_to_sc_rollup)\n >>?= fun sender ->\n (* Adding the message to the inbox. Note that it is safe to ignore the\n size diff since only its hash and meta data are stored in the context.\n See #3232. *)\n Sc_rollup.Inbox.add_deposit\n ctxt\n ~destination\n ~payload\n ~sender\n ~source:payer\n >>=? fun ctxt ->\n Ticket_scanner.type_has_tickets ctxt parameters_ty\n >>?= fun (has_tickets, ctxt) ->\n Ticket_accounting.ticket_balances_of_value\n ctxt\n ~include_lazy:true\n has_tickets\n parameters\n >>=? fun (ticket_token_map, ctxt) ->\n (* TODO: https://gitlab.com/tezos/tezos/-/issues/4354\n Factor out function for constructing a ticket receipt.\n There are multiple places where we compute the receipt from a\n ticket-token-map. We should factor out and reuse this logic. *)\n Ticket_token_map.fold_es\n ctxt\n (fun ctxt acc ex_token amount ->\n Ticket_token_unparser.unparse ctxt ex_token\n >>=? fun (ticket_token, ctxt) ->\n let item =\n Ticket_receipt.\n {\n ticket_token;\n updates =\n [{account = Destination.Sc_rollup destination; amount}];\n }\n in\n return (item :: acc, ctxt))\n []\n ticket_token_map\n >|=? fun (ticket_receipt, ctxt) ->\n let consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt in\n let result =\n Transaction_to_sc_rollup_result {consumed_gas; ticket_receipt}\n in\n (ctxt, ITransaction_result result, [])\n | Event {ty = _; unparsed_data = _; tag = _} ->\n return\n ( ctxt,\n IEvent_result\n {consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt},\n [] )\n | Transaction_to_zk_rollup\n {destination; unparsed_parameters = _; parameters_ty; parameters} ->\n Zk_rollup_apply.transaction_to_zk_rollup\n ~ctxt\n ~parameters_ty\n ~parameters\n ~dst_rollup:destination\n ~since:ctxt_before_op\n | Origination\n {\n delegate;\n code = unparsed_code;\n unparsed_storage = _;\n credit;\n preorigination;\n storage_type;\n storage;\n } ->\n assert_source_is_contract source >>?= fun source ->\n apply_origination\n ~ctxt\n ~storage_type\n ~storage\n ~unparsed_code\n ~contract:preorigination\n ~delegate\n ~source\n ~credit\n ~before_operation:ctxt_before_op\n >|=? fun (ctxt, origination_result, ops) ->\n (ctxt, IOrigination_result origination_result, ops)\n | Delegation delegate ->\n assert_source_is_contract source >>?= fun source ->\n apply_delegation ~ctxt ~source ~delegate ~before_operation:ctxt_before_op\n >|=? fun (ctxt, consumed_gas, ops) ->\n (ctxt, IDelegation_result {consumed_gas}, ops)\n\nlet apply_manager_operation :\n type kind.\n context ->\n source:public_key_hash ->\n chain_id:Chain_id.t ->\n kind manager_operation ->\n (context\n * kind successful_manager_operation_result\n * Script_typed_ir.packed_internal_operation list)\n tzresult\n Lwt.t =\n fun ctxt_before_op ~source ~chain_id operation ->\n let source_contract = Contract.Implicit source in\n Gas.consume ctxt_before_op Michelson_v1_gas.Cost_of.manager_operation\n >>?= fun ctxt ->\n (* Note that [ctxt_before_op] will be used again later to compute\n gas consumption and originations for the operation result (by\n comparing it with the [ctxt] we will have at the end of the\n application). *)\n let consume_deserialization_gas =\n (* Note that we used to set this to [Script.When_needed] because\n the deserialization gas was accounted for in the gas consumed\n by precheck. However, we no longer have access to this precheck\n gas, so we want to always consume the deserialization gas\n again, independently of the internal state of the lazy_exprs in\n the arguments. *)\n Script.Always\n in\n match operation with\n | Reveal pk ->\n (* TODO #2603\n\n Even if [precheck_manager_contents] has already asserted that\n the implicit contract is allocated, we must re-do this check in\n case the manager has been emptied while collecting fees. This\n should be solved by forking out [validate_operation] from\n [apply_operation]. *)\n Contract.must_be_allocated ctxt source_contract >>=? fun () ->\n (* TODO tezos/tezos#3070\n\n We have already asserted the consistency of the supplied public\n key during precheck, so we avoid re-checking that precondition\n with [?check_consistency=false]. This optional parameter is\n temporary, to avoid breaking compatibility with external legacy\n usage of [Contract.reveal_manager_key]. However, the pattern of\n using [Contract.check_public_key] and this usage of\n [Contract.reveal_manager_key] should become the standard. *)\n Contract.reveal_manager_key ~check_consistency:false ctxt source pk\n >>=? fun ctxt ->\n return\n ( ctxt,\n (Reveal_result\n {consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt}\n : kind successful_manager_operation_result),\n [] )\n | Transaction {amount; parameters; destination = Implicit pkh; entrypoint} ->\n Script.force_decode_in_context\n ~consume_deserialization_gas\n ctxt\n parameters\n >>?= fun (parameters, ctxt) ->\n (* Only allow [Unit] parameter to implicit accounts. *)\n (match Micheline.root parameters with\n | Prim (_, Michelson_v1_primitives.D_Unit, [], _) -> Result.return_unit\n | _ -> error (Script_interpreter.Bad_contract_parameter source_contract))\n >>?= fun () ->\n (if Entrypoint.is_default entrypoint then Result.return_unit\n else error (Script_tc_errors.No_such_entrypoint entrypoint))\n >>?= fun () ->\n apply_transaction_to_implicit\n ~ctxt\n ~source:source_contract\n ~amount\n ~pkh\n ~before_operation:ctxt_before_op\n >|=? fun (ctxt, res, ops) -> (ctxt, Transaction_result res, ops)\n | Transaction\n {amount; parameters; destination = Originated contract_hash; entrypoint}\n ->\n Script.force_decode_in_context\n ~consume_deserialization_gas\n ctxt\n parameters\n >>?= fun (parameters, ctxt) ->\n apply_transaction_to_smart_contract\n ~ctxt\n ~source:(Destination.Contract source_contract)\n ~contract_hash\n ~amount\n ~entrypoint\n ~before_operation:ctxt_before_op\n ~payer:source\n ~chain_id\n ~internal:false\n ~parameter:(Untyped_arg parameters)\n >|=? fun (ctxt, res, ops) -> (ctxt, Transaction_result res, ops)\n | Tx_rollup_dispatch_tickets\n {\n tx_rollup;\n level;\n context_hash;\n message_index;\n message_result_path;\n tickets_info;\n } ->\n Tx_rollup_state.get ctxt tx_rollup >>=? fun (ctxt, state) ->\n Tx_rollup_commitment.get_finalized ctxt tx_rollup state level\n >>=? fun (ctxt, commitment) ->\n Tx_rollup_reveal.mem ctxt tx_rollup level ~message_position:message_index\n >>=? fun (ctxt, already_revealed) ->\n error_when\n already_revealed\n Tx_rollup_errors.Withdrawals_already_dispatched\n >>?= fun () ->\n (* The size of the list [tickets_info] is bounded by a\n parametric constant, and checked in precheck. *)\n List.fold_left_es\n (fun (acc_withdraw, acc, ctxt)\n Tx_rollup_reveal.{contents; ty; ticketer; amount; claimer} ->\n error_when\n Tx_rollup_l2_qty.(amount <= zero)\n Script_tc_errors.Forbidden_zero_ticket_quantity\n >>?= fun () ->\n Ticket_transfer.parse_ticket\n ~consume_deserialization_gas\n ~ticketer\n ~contents\n ~ty\n ctxt\n >>=? fun (ctxt, ticket_token) ->\n Ticket_balance_key.of_ex_token\n ctxt\n ~owner:(Tx_rollup tx_rollup)\n ticket_token\n >>=? fun (ticket_hash, ctxt) ->\n let withdrawal = Tx_rollup_withdraw.{claimer; ticket_hash; amount} in\n return\n (withdrawal :: acc_withdraw, (withdrawal, ticket_token) :: acc, ctxt))\n ([], [], ctxt)\n tickets_info\n >>=? fun (rev_withdraw_list, rev_ex_token_and_hash_list, ctxt) ->\n Tx_rollup_hash.withdraw_list ctxt (List.rev rev_withdraw_list)\n >>?= fun (ctxt, withdraw_list_hash) ->\n Tx_rollup_commitment.check_message_result\n ctxt\n commitment.commitment\n (`Result {context_hash; withdraw_list_hash})\n ~path:message_result_path\n ~index:message_index\n >>?= fun ctxt ->\n Tx_rollup_reveal.record\n ctxt\n tx_rollup\n level\n ~message_position:message_index\n >>=? fun ctxt ->\n let adjust_ticket_balance (ctxt, acc_diff)\n ( Tx_rollup_withdraw.\n {claimer; amount; ticket_hash = tx_rollup_ticket_hash},\n ticket_token ) =\n Tx_rollup_l2_qty.to_z amount\n |> Ticket_amount.of_zint\n |> Option.value_e\n ~error:\n (Error_monad.trace_of_error\n Script_tc_errors.Forbidden_zero_ticket_quantity)\n >>?= fun amount ->\n Ticket_balance_key.of_ex_token\n ctxt\n ~owner:(Contract (Contract.Implicit claimer))\n ticket_token\n >>=? fun (claimer_ticket_hash, ctxt) ->\n Ticket_transfer.transfer_ticket_with_hashes\n ctxt\n ~src_hash:tx_rollup_ticket_hash\n ~dst_hash:claimer_ticket_hash\n amount\n >>=? fun (ctxt, diff) -> return (ctxt, Z.(add acc_diff diff))\n in\n List.fold_left_es\n adjust_ticket_balance\n (ctxt, Z.zero)\n rev_ex_token_and_hash_list\n >>=? fun (ctxt, paid_storage_size_diff) ->\n let result =\n Tx_rollup_dispatch_tickets_result\n {\n balance_updates = [];\n consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt;\n paid_storage_size_diff;\n }\n in\n return (ctxt, result, [])\n | Transfer_ticket {contents; ty; ticketer; amount; destination; entrypoint}\n -> (\n match destination with\n | Implicit _ ->\n error_unless\n Entrypoint.(entrypoint = default)\n (Script_tc_errors.No_such_entrypoint entrypoint)\n >>?= fun () ->\n Ticket_transfer.parse_ticket\n ~consume_deserialization_gas\n ~ticketer\n ~contents\n ~ty\n ctxt\n >>=? fun (ctxt, ticket) ->\n Ticket_transfer.transfer_ticket\n ctxt\n ~src:(Contract source_contract)\n ~dst:(Contract destination)\n ticket\n amount\n >>=? fun (ctxt, paid_storage_size_diff) ->\n Ticket_token_unparser.unparse ctxt ticket\n >>=? fun (ticket_token, ctxt) ->\n let amount = Script_int.(to_zint (amount :> n num)) in\n let ticket_receipt =\n Ticket_receipt.\n [\n {\n ticket_token;\n updates =\n [\n {account = Contract source_contract; amount = Z.neg amount};\n {account = Contract destination; amount};\n ];\n };\n ]\n in\n return\n ( ctxt,\n Transfer_ticket_result\n {\n balance_updates = [];\n ticket_receipt;\n consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt;\n paid_storage_size_diff;\n },\n [] )\n | Originated destination_hash ->\n Ticket_transfer.parse_ticket_and_operation\n ~consume_deserialization_gas\n ~ticketer\n ~contents\n ~ty\n ~source:(Destination.Contract source_contract)\n ~destination:destination_hash\n ~entrypoint\n ~amount\n ctxt\n >>=? fun (ctxt, token, op) ->\n Ticket_transfer.transfer_ticket\n ctxt\n ~src:(Contract source_contract)\n ~dst:(Contract destination)\n token\n amount\n >>=? fun (ctxt, paid_storage_size_diff) ->\n Ticket_token_unparser.unparse ctxt token\n >>=? fun (ticket_token, ctxt) ->\n let amount = Script_int.(to_zint (amount :> n num)) in\n let ticket_receipt =\n Ticket_receipt.\n [\n {\n ticket_token;\n updates =\n [\n {account = Contract source_contract; amount = Z.neg amount}\n (* The transfer of the ticket to [destination] is part of the internal operation [op]. *);\n ];\n };\n ]\n in\n return\n ( ctxt,\n Transfer_ticket_result\n {\n balance_updates = [];\n ticket_receipt;\n consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt;\n paid_storage_size_diff;\n },\n [op] ))\n | Origination {delegate; script; credit} ->\n (* Internal originations have their address generated in the interpreter\n so that the script can use it immediately.\n The address of external originations is generated here. *)\n Contract.fresh_contract_from_current_nonce ctxt\n >>?= fun (ctxt, contract) ->\n Script.force_decode_in_context\n ~consume_deserialization_gas\n ctxt\n script.Script.storage\n >>?= fun (_unparsed_storage, ctxt) ->\n Script.force_decode_in_context\n ~consume_deserialization_gas\n ctxt\n script.Script.code\n >>?= fun (unparsed_code, ctxt) ->\n Script_ir_translator.parse_script\n ctxt\n ~elab_conf:Script_ir_translator_config.(make ~legacy:false ())\n ~allow_forged_in_storage:false\n script\n >>=? fun (Ex_script parsed_script, ctxt) ->\n let (Script {storage_type; views; storage; _}) = parsed_script in\n let views_result =\n Script_ir_translator.parse_views\n ctxt\n ~elab_conf:Script_ir_translator_config.(make ~legacy:false ())\n storage_type\n views\n in\n trace\n (Script_tc_errors.Ill_typed_contract (unparsed_code, []))\n views_result\n >>=? fun (_typed_views, ctxt) ->\n apply_origination\n ~ctxt\n ~storage_type\n ~storage\n ~unparsed_code\n ~contract\n ~delegate\n ~source:source_contract\n ~credit\n ~before_operation:ctxt_before_op\n >|=? fun (ctxt, origination_result, ops) ->\n (ctxt, Origination_result origination_result, ops)\n | Delegation delegate ->\n apply_delegation\n ~ctxt\n ~source:source_contract\n ~delegate\n ~before_operation:ctxt_before_op\n >|=? fun (ctxt, consumed_gas, ops) ->\n (ctxt, Delegation_result {consumed_gas}, ops)\n | Register_global_constant {value} ->\n (* Decode the value and consume gas appropriately *)\n Script.force_decode_in_context ~consume_deserialization_gas ctxt value\n >>?= fun (expr, ctxt) ->\n (* Set the key to the value in storage. *)\n Global_constants_storage.register ctxt expr\n >>=? fun (ctxt, address, size) ->\n (* The burn and the reporting of the burn are calculated differently.\n\n [Fees.record_global_constant_storage_space] does the actual burn\n based on the size of the constant registered, and this causes a\n change in account balance.\n\n On the other hand, the receipt is calculated\n with the help of [Fees.cost_of_bytes], and is included in block metadata\n and the client output. The receipt is also used during simulation,\n letting the client automatically set an appropriate storage limit.\n TODO : is this concern still honored by the token management\n refactoring ? *)\n let ctxt, paid_size =\n Fees.record_global_constant_storage_space ctxt size\n in\n let result =\n Register_global_constant_result\n {\n balance_updates = [];\n consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt;\n size_of_constant = paid_size;\n global_address = address;\n }\n in\n return (ctxt, result, [])\n | Set_deposits_limit limit ->\n (match limit with\n | None -> Result.return_unit\n | Some limit ->\n let frozen_deposits_percentage =\n Constants.frozen_deposits_percentage ctxt\n in\n let max_limit =\n Tez.of_mutez_exn\n Int64.(\n mul (of_int frozen_deposits_percentage) Int64.(div max_int 100L))\n in\n error_when\n Tez.(limit > max_limit)\n (Set_deposits_limit_too_high {limit; max_limit}))\n >>?= fun () ->\n Delegate.registered ctxt source >>= fun is_registered ->\n error_unless\n is_registered\n (Set_deposits_limit_on_unregistered_delegate source)\n >>?= fun () ->\n Delegate.set_frozen_deposits_limit ctxt source limit >>= fun ctxt ->\n return\n ( ctxt,\n Set_deposits_limit_result\n {consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt},\n [] )\n | Increase_paid_storage {amount_in_bytes; destination} ->\n Contract.increase_paid_storage ctxt destination ~amount_in_bytes\n >>=? fun ctxt ->\n let payer = `Contract (Contract.Implicit source) in\n Fees.burn_storage_increase_fees ctxt ~payer amount_in_bytes\n >|=? fun (ctxt, storage_bus) ->\n let result =\n Increase_paid_storage_result\n {\n balance_updates = storage_bus;\n consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt;\n }\n in\n (ctxt, result, [])\n | Update_consensus_key pk ->\n Delegate.registered ctxt source >>= fun is_registered ->\n error_unless\n is_registered\n (Update_consensus_key_on_unregistered_delegate source)\n >>?= fun () ->\n Delegate.Consensus_key.register_update ctxt source pk >>=? fun ctxt ->\n return\n ( ctxt,\n Update_consensus_key_result\n {consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt},\n [] )\n | Tx_rollup_origination ->\n Tx_rollup.originate ctxt >>=? fun (ctxt, originated_tx_rollup) ->\n let result =\n Tx_rollup_origination_result\n {\n consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt;\n originated_tx_rollup;\n balance_updates = [];\n }\n in\n return (ctxt, result, [])\n | Tx_rollup_submit_batch {tx_rollup; content; burn_limit} ->\n let message, message_size = Tx_rollup_message.make_batch content in\n Tx_rollup_gas.hash_cost message_size >>?= fun cost ->\n Gas.consume ctxt cost >>?= fun ctxt ->\n Tx_rollup_state.get ctxt tx_rollup >>=? fun (ctxt, state) ->\n Tx_rollup_inbox.append_message ctxt tx_rollup state message\n >>=? fun (ctxt, state, paid_storage_size_diff) ->\n Tx_rollup_state.burn_cost ~limit:burn_limit state message_size\n >>?= fun cost ->\n Token.transfer ctxt (`Contract source_contract) `Burned cost\n >>=? fun (ctxt, balance_updates) ->\n Tx_rollup_state.update ctxt tx_rollup state >>=? fun ctxt ->\n let result =\n Tx_rollup_submit_batch_result\n {\n consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt;\n balance_updates;\n paid_storage_size_diff;\n }\n in\n return (ctxt, result, [])\n | Tx_rollup_commit {tx_rollup; commitment} ->\n Tx_rollup_state.get ctxt tx_rollup >>=? fun (ctxt, state) ->\n ( Tx_rollup_commitment.has_bond ctxt tx_rollup source\n >>=? fun (ctxt, pending) ->\n if not pending then\n let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in\n Token.transfer\n ctxt\n (`Contract source_contract)\n (`Frozen_bonds (source_contract, bond_id))\n (Constants.tx_rollup_commitment_bond ctxt)\n else return (ctxt, []) )\n >>=? fun (ctxt, balance_updates) ->\n Tx_rollup_commitment.add_commitment ctxt tx_rollup state source commitment\n >>=? fun (ctxt, state, to_slash) ->\n (match to_slash with\n | Some pkh ->\n let committer = Contract.Implicit pkh in\n Tx_rollup_commitment.slash_bond ctxt tx_rollup pkh\n >>=? fun (ctxt, slashed) ->\n if slashed then\n let bid = Bond_id.Tx_rollup_bond_id tx_rollup in\n Token.balance ctxt (`Frozen_bonds (committer, bid))\n >>=? fun (ctxt, burn) ->\n Token.transfer\n ctxt\n (`Frozen_bonds (committer, bid))\n `Tx_rollup_rejection_punishments\n burn\n else return (ctxt, [])\n | None -> return (ctxt, []))\n >>=? fun (ctxt, burn_update) ->\n Tx_rollup_state.update ctxt tx_rollup state >>=? fun ctxt ->\n let result =\n Tx_rollup_commit_result\n {\n consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt;\n balance_updates = burn_update @ balance_updates;\n }\n in\n return (ctxt, result, [])\n | Tx_rollup_return_bond {tx_rollup} ->\n Tx_rollup_commitment.remove_bond ctxt tx_rollup source >>=? fun ctxt ->\n let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in\n Token.balance ctxt (`Frozen_bonds (source_contract, bond_id))\n >>=? fun (ctxt, bond) ->\n Token.transfer\n ctxt\n (`Frozen_bonds (source_contract, bond_id))\n (`Contract source_contract)\n bond\n >>=? fun (ctxt, balance_updates) ->\n let result =\n Tx_rollup_return_bond_result\n {\n consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt;\n balance_updates;\n }\n in\n return (ctxt, result, [])\n | Tx_rollup_finalize_commitment {tx_rollup} ->\n Tx_rollup_state.get ctxt tx_rollup >>=? fun (ctxt, state) ->\n Tx_rollup_commitment.finalize_commitment ctxt tx_rollup state\n >>=? fun (ctxt, state, level) ->\n Tx_rollup_state.update ctxt tx_rollup state >>=? fun ctxt ->\n let result =\n Tx_rollup_finalize_commitment_result\n {\n consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt;\n balance_updates = [];\n level;\n }\n in\n return (ctxt, result, [])\n | Tx_rollup_remove_commitment {tx_rollup} ->\n Tx_rollup_state.get ctxt tx_rollup >>=? fun (ctxt, state) ->\n Tx_rollup_commitment.remove_commitment ctxt tx_rollup state\n >>=? fun (ctxt, state, level) ->\n Tx_rollup_state.update ctxt tx_rollup state >>=? fun ctxt ->\n let result =\n Tx_rollup_remove_commitment_result\n {\n consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt;\n balance_updates = [];\n level;\n }\n in\n return (ctxt, result, [])\n | Tx_rollup_rejection\n {\n proof;\n tx_rollup;\n level;\n message;\n message_position;\n message_path;\n message_result_hash;\n message_result_path;\n previous_message_result;\n previous_message_result_path;\n } -> (\n Tx_rollup_state.get ctxt tx_rollup >>=? fun (ctxt, state) ->\n (* Check [level] *)\n Tx_rollup_state.check_level_can_be_rejected state level >>?= fun () ->\n Tx_rollup_commitment.get ctxt tx_rollup state level\n >>=? fun (ctxt, commitment) ->\n (* Check [message] *)\n error_when\n Compare.Int.(\n message_position < 0\n || commitment.commitment.messages.count <= message_position)\n (Tx_rollup_errors.Wrong_message_position\n {\n level = commitment.commitment.level;\n position = message_position;\n length = commitment.commitment.messages.count;\n })\n >>?= fun () ->\n Tx_rollup_inbox.check_message_hash\n ctxt\n level\n tx_rollup\n ~position:message_position\n message\n message_path\n >>=? fun ctxt ->\n (* Check message result paths *)\n Tx_rollup_commitment.check_agreed_and_disputed_results\n ctxt\n tx_rollup\n state\n commitment\n ~agreed_result:previous_message_result\n ~agreed_result_path:previous_message_result_path\n ~disputed_result:message_result_hash\n ~disputed_result_path:message_result_path\n ~disputed_position:message_position\n >>=? fun ctxt ->\n (* Check [proof] *)\n let parameters =\n Tx_rollup_l2_apply.\n {\n tx_rollup_max_withdrawals_per_batch =\n Constants.tx_rollup_max_withdrawals_per_batch ctxt;\n }\n in\n let proof_length = Tx_rollup_l2_proof.length proof in\n match Tx_rollup_l2_proof.proof_of_serialized_opt proof with\n | Some proof ->\n Tx_rollup_l2_verifier.verify_proof\n ctxt\n parameters\n message\n proof\n ~proof_length\n ~agreed:previous_message_result\n ~rejected:message_result_hash\n ~max_proof_size:(Constants.tx_rollup_rejection_max_proof_size ctxt)\n >>=? fun ctxt ->\n (* Proof is correct, removing *)\n Tx_rollup_commitment.reject_commitment ctxt tx_rollup state level\n >>=? fun (ctxt, state) ->\n (* Bond slashing, and removing *)\n Tx_rollup_commitment.slash_bond ctxt tx_rollup commitment.committer\n >>=? fun (ctxt, slashed) ->\n (if slashed then\n let committer = Contract.Implicit commitment.committer in\n let bid = Bond_id.Tx_rollup_bond_id tx_rollup in\n Token.balance ctxt (`Frozen_bonds (committer, bid))\n >>=? fun (ctxt, burn) ->\n Tez.(burn /? 2L) >>?= fun reward ->\n Token.transfer\n ctxt\n (`Frozen_bonds (committer, bid))\n `Tx_rollup_rejection_punishments\n burn\n >>=? fun (ctxt, burn_update) ->\n Token.transfer\n ctxt\n `Tx_rollup_rejection_rewards\n (`Contract source_contract)\n reward\n >>=? fun (ctxt, reward_update) ->\n return (ctxt, burn_update @ reward_update)\n else return (ctxt, []))\n >>=? fun (ctxt, balance_updates) ->\n (* Update state and conclude *)\n Tx_rollup_state.update ctxt tx_rollup state >>=? fun ctxt ->\n let result =\n Tx_rollup_rejection_result\n {\n consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt;\n balance_updates;\n }\n in\n return (ctxt, result, [])\n | None -> tzfail Tx_rollup_errors.Proof_undecodable)\n | Dal_publish_slot_header slot_header ->\n Dal_apply.apply_publish_slot_header ctxt slot_header >>?= fun ctxt ->\n let consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt in\n let result = Dal_publish_slot_header_result {consumed_gas} in\n return (ctxt, result, [])\n | Sc_rollup_originate {kind; boot_sector; origination_proof; parameters_ty} ->\n Sc_rollup_operations.originate\n ctxt\n ~kind\n ~boot_sector\n ~origination_proof\n ~parameters_ty\n >>=? fun ({address; size; genesis_commitment_hash}, ctxt) ->\n let consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt in\n let result =\n Sc_rollup_originate_result\n {\n address;\n genesis_commitment_hash;\n consumed_gas;\n size;\n balance_updates = [];\n }\n in\n return (ctxt, result, [])\n | Sc_rollup_add_messages {messages} ->\n Sc_rollup.Inbox.add_external_messages ctxt messages >>=? fun ctxt ->\n let consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt in\n let result = Sc_rollup_add_messages_result {consumed_gas} in\n return (ctxt, result, [])\n | Sc_rollup_cement {rollup; commitment} ->\n Sc_rollup.Stake_storage.cement_commitment ctxt rollup commitment\n >>=? fun (ctxt, commitment) ->\n let consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt in\n let result =\n Sc_rollup_cement_result\n {consumed_gas; inbox_level = commitment.inbox_level}\n in\n return (ctxt, result, [])\n | Sc_rollup_publish {rollup; commitment} ->\n Sc_rollup.Stake_storage.publish_commitment ctxt rollup source commitment\n >>=? fun (staked_hash, published_at_level, ctxt, balance_updates) ->\n let consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt in\n let result =\n Sc_rollup_publish_result\n {staked_hash; consumed_gas; published_at_level; balance_updates}\n in\n return (ctxt, result, [])\n | Sc_rollup_refute {rollup; opponent; refutation} ->\n let open Sc_rollup.Refutation_storage in\n let player = source in\n (match refutation with\n | Start {player_commitment_hash; opponent_commitment_hash} ->\n start_game\n ctxt\n rollup\n ~player:(player, player_commitment_hash)\n ~opponent:(opponent, opponent_commitment_hash)\n >>=? fun ctxt -> return (None, ctxt)\n | Move {step; choice} ->\n game_move ctxt rollup ~player ~opponent ~step ~choice)\n >>=? fun (game_result, ctxt) ->\n (match game_result with\n | None -> return (Sc_rollup.Game.Ongoing, ctxt, [])\n | Some game_result ->\n let stakers = Sc_rollup.Game.Index.make source opponent in\n Sc_rollup.Refutation_storage.apply_game_result\n ctxt\n rollup\n stakers\n game_result)\n >>=? fun (game_status, ctxt, balance_updates) ->\n let consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt in\n let result =\n Sc_rollup_refute_result {game_status; consumed_gas; balance_updates}\n in\n return (ctxt, result, [])\n | Sc_rollup_timeout {rollup; stakers} ->\n Sc_rollup.Refutation_storage.timeout ctxt rollup stakers\n >>=? fun (game_result, ctxt) ->\n Sc_rollup.Refutation_storage.apply_game_result\n ctxt\n rollup\n stakers\n game_result\n >>=? fun (game_status, ctxt, balance_updates) ->\n let consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt in\n let result =\n Sc_rollup_timeout_result {game_status; consumed_gas; balance_updates}\n in\n return (ctxt, result, [])\n | Sc_rollup_execute_outbox_message {rollup; cemented_commitment; output_proof}\n ->\n Sc_rollup_operations.execute_outbox_message\n ctxt\n rollup\n ~cemented_commitment\n ~output_proof\n >|=? fun ( {\n Sc_rollup_operations.paid_storage_size_diff;\n ticket_receipt;\n operations;\n },\n ctxt ) ->\n let consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt in\n let result =\n Sc_rollup_execute_outbox_message_result\n {\n paid_storage_size_diff;\n ticket_receipt;\n balance_updates = [];\n consumed_gas;\n }\n in\n (ctxt, result, operations)\n | Sc_rollup_recover_bond {sc_rollup; staker} ->\n Sc_rollup.Stake_storage.withdraw_stake ctxt sc_rollup staker\n >>=? fun (ctxt, balance_updates) ->\n let result =\n Sc_rollup_recover_bond_result\n {\n consumed_gas = Gas.consumed ~since:ctxt_before_op ~until:ctxt;\n balance_updates;\n }\n in\n return (ctxt, result, [])\n | Zk_rollup_origination {public_parameters; circuits_info; init_state; nb_ops}\n ->\n Zk_rollup_apply.originate\n ~ctxt_before_op\n ~ctxt\n ~public_parameters\n ~circuits_info\n ~init_state\n ~nb_ops\n | Zk_rollup_publish {zk_rollup; ops} ->\n Zk_rollup_apply.publish ~ctxt_before_op ~ctxt ~zk_rollup ~l2_ops:ops\n | Zk_rollup_update {zk_rollup; update} ->\n Zk_rollup_apply.update ~ctxt_before_op ~ctxt ~zk_rollup ~update\n\ntype success_or_failure = Success of context | Failure\n\nlet apply_internal_operations ctxt ~payer ~chain_id ops =\n let rec apply ctxt applied worklist =\n match worklist with\n | [] -> Lwt.return (Success ctxt, List.rev applied)\n | Script_typed_ir.Internal_operation ({source; operation; nonce} as op)\n :: rest -> (\n (if internal_nonce_already_recorded ctxt nonce then\n let op_res = Apply_internal_results.internal_operation op in\n tzfail (Internal_operation_replay (Internal_operation op_res))\n else\n let ctxt = record_internal_nonce ctxt nonce in\n apply_internal_operation_contents\n ctxt\n ~source\n ~payer\n ~chain_id\n operation)\n >>= function\n | Error errors ->\n let result =\n pack_internal_operation_result\n op\n (Failed (Script_typed_ir.manager_kind op.operation, errors))\n in\n let skipped =\n List.rev_map\n (fun (Script_typed_ir.Internal_operation op) ->\n pack_internal_operation_result\n op\n (Skipped (Script_typed_ir.manager_kind op.operation)))\n rest\n in\n Lwt.return (Failure, List.rev (skipped @ (result :: applied)))\n | Ok (ctxt, result, emitted) ->\n apply\n ctxt\n (pack_internal_operation_result op (Applied result) :: applied)\n (emitted @ rest))\n in\n apply ctxt [] ops\n\nlet burn_transaction_storage_fees ctxt trr ~storage_limit ~payer =\n match trr with\n | Transaction_to_contract_result payload ->\n let consumed = payload.paid_storage_size_diff in\n Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed\n >>=? fun (ctxt, storage_limit, storage_bus) ->\n (if payload.allocated_destination_contract then\n Fees.burn_origination_fees ctxt ~storage_limit ~payer\n else return (ctxt, storage_limit, []))\n >>=? fun (ctxt, storage_limit, origination_bus) ->\n let balance_updates =\n storage_bus @ payload.balance_updates @ origination_bus\n in\n return\n ( ctxt,\n storage_limit,\n Transaction_to_contract_result\n {\n storage = payload.storage;\n lazy_storage_diff = payload.lazy_storage_diff;\n balance_updates;\n ticket_receipt = payload.ticket_receipt;\n originated_contracts = payload.originated_contracts;\n consumed_gas = payload.consumed_gas;\n storage_size = payload.storage_size;\n paid_storage_size_diff = payload.paid_storage_size_diff;\n allocated_destination_contract =\n payload.allocated_destination_contract;\n } )\n | Transaction_to_tx_rollup_result payload ->\n let consumed = payload.paid_storage_size_diff in\n Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed\n >>=? fun (ctxt, storage_limit, storage_bus) ->\n let balance_updates = storage_bus @ payload.balance_updates in\n return\n ( ctxt,\n storage_limit,\n Transaction_to_tx_rollup_result {payload with balance_updates} )\n | Transaction_to_sc_rollup_result _ -> return (ctxt, storage_limit, trr)\n | Transaction_to_zk_rollup_result payload ->\n let consumed = payload.paid_storage_size_diff in\n Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed\n >>=? fun (ctxt, storage_limit, storage_bus) ->\n let balance_updates = storage_bus @ payload.balance_updates in\n return\n ( ctxt,\n storage_limit,\n Transaction_to_zk_rollup_result {payload with balance_updates} )\n\nlet burn_origination_storage_fees ctxt\n {\n lazy_storage_diff;\n balance_updates;\n originated_contracts;\n consumed_gas;\n storage_size;\n paid_storage_size_diff;\n } ~storage_limit ~payer =\n let consumed = paid_storage_size_diff in\n Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed\n >>=? fun (ctxt, storage_limit, storage_bus) ->\n Fees.burn_origination_fees ctxt ~storage_limit ~payer\n >>=? fun (ctxt, storage_limit, origination_bus) ->\n let balance_updates = storage_bus @ origination_bus @ balance_updates in\n return\n ( ctxt,\n storage_limit,\n {\n lazy_storage_diff;\n balance_updates;\n originated_contracts;\n consumed_gas;\n storage_size;\n paid_storage_size_diff;\n } )\n\n(** [burn_manager_storage_fees ctxt smopr storage_limit payer] burns the\n storage fees associated to an external operation result [smopr].\n Returns an updated context, an updated storage limit with the space consumed\n by the operation subtracted, and [smopr] with the relevant balance updates\n included. *)\nlet burn_manager_storage_fees :\n type kind.\n context ->\n kind successful_manager_operation_result ->\n storage_limit:Z.t ->\n payer:public_key_hash ->\n (context * Z.t * kind successful_manager_operation_result) tzresult Lwt.t =\n fun ctxt smopr ~storage_limit ~payer ->\n let payer = `Contract (Contract.Implicit payer) in\n match smopr with\n | Transaction_result transaction_result ->\n burn_transaction_storage_fees\n ctxt\n transaction_result\n ~storage_limit\n ~payer\n >>=? fun (ctxt, storage_limit, transaction_result) ->\n return (ctxt, storage_limit, Transaction_result transaction_result)\n | Origination_result origination_result ->\n burn_origination_storage_fees\n ctxt\n origination_result\n ~storage_limit\n ~payer\n >>=? fun (ctxt, storage_limit, origination_result) ->\n return (ctxt, storage_limit, Origination_result origination_result)\n | Reveal_result _ | Delegation_result _ -> return (ctxt, storage_limit, smopr)\n | Register_global_constant_result payload ->\n let consumed = payload.size_of_constant in\n Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed\n >|=? fun (ctxt, storage_limit, storage_bus) ->\n let balance_updates = storage_bus @ payload.balance_updates in\n ( ctxt,\n storage_limit,\n Register_global_constant_result\n {\n balance_updates;\n consumed_gas = payload.consumed_gas;\n size_of_constant = payload.size_of_constant;\n global_address = payload.global_address;\n } )\n | Set_deposits_limit_result _ | Update_consensus_key_result _ ->\n return (ctxt, storage_limit, smopr)\n | Increase_paid_storage_result _ -> return (ctxt, storage_limit, smopr)\n | Tx_rollup_origination_result payload ->\n Fees.burn_tx_rollup_origination_fees ctxt ~storage_limit ~payer\n >|=? fun (ctxt, storage_limit, origination_bus) ->\n let balance_updates = origination_bus @ payload.balance_updates in\n ( ctxt,\n storage_limit,\n Tx_rollup_origination_result {payload with balance_updates} )\n | Tx_rollup_return_bond_result _ | Tx_rollup_remove_commitment_result _\n | Tx_rollup_rejection_result _ | Tx_rollup_finalize_commitment_result _\n | Tx_rollup_commit_result _ ->\n return (ctxt, storage_limit, smopr)\n | Transfer_ticket_result payload ->\n let consumed = payload.paid_storage_size_diff in\n Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed\n >|=? fun (ctxt, storage_limit, storage_bus) ->\n let balance_updates = payload.balance_updates @ storage_bus in\n ( ctxt,\n storage_limit,\n Transfer_ticket_result {payload with balance_updates} )\n | Tx_rollup_submit_batch_result payload ->\n let consumed = payload.paid_storage_size_diff in\n Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed\n >|=? fun (ctxt, storage_limit, storage_bus) ->\n let balance_updates = storage_bus @ payload.balance_updates in\n ( ctxt,\n storage_limit,\n Tx_rollup_submit_batch_result {payload with balance_updates} )\n | Tx_rollup_dispatch_tickets_result payload ->\n let consumed = payload.paid_storage_size_diff in\n Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed\n >|=? fun (ctxt, storage_limit, storage_bus) ->\n let balance_updates = storage_bus @ payload.balance_updates in\n ( ctxt,\n storage_limit,\n Tx_rollup_dispatch_tickets_result {payload with balance_updates} )\n | Dal_publish_slot_header_result _ -> return (ctxt, storage_limit, smopr)\n | Sc_rollup_originate_result payload ->\n Fees.burn_sc_rollup_origination_fees\n ctxt\n ~storage_limit\n ~payer\n payload.size\n >|=? fun (ctxt, storage_limit, balance_updates) ->\n let result = Sc_rollup_originate_result {payload with balance_updates} in\n (ctxt, storage_limit, result)\n | Sc_rollup_add_messages_result _ -> return (ctxt, storage_limit, smopr)\n | Sc_rollup_cement_result _ -> return (ctxt, storage_limit, smopr)\n | Sc_rollup_publish_result _ -> return (ctxt, storage_limit, smopr)\n | Sc_rollup_refute_result _ -> return (ctxt, storage_limit, smopr)\n | Sc_rollup_timeout_result _ -> return (ctxt, storage_limit, smopr)\n | Sc_rollup_execute_outbox_message_result\n ({paid_storage_size_diff; balance_updates; _} as payload) ->\n let consumed = paid_storage_size_diff in\n Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed\n >|=? fun (ctxt, storage_limit, storage_bus) ->\n let balance_updates = storage_bus @ balance_updates in\n ( ctxt,\n storage_limit,\n Sc_rollup_execute_outbox_message_result {payload with balance_updates}\n )\n | Sc_rollup_recover_bond_result _ -> return (ctxt, storage_limit, smopr)\n | Zk_rollup_origination_result payload ->\n Fees.burn_zk_rollup_origination_fees\n ctxt\n ~storage_limit\n ~payer\n payload.storage_size\n >>=? fun (ctxt, storage_limit, balance_updates) ->\n let result =\n Zk_rollup_origination_result {payload with balance_updates}\n in\n return (ctxt, storage_limit, result)\n | Zk_rollup_publish_result payload ->\n let consumed = payload.paid_storage_size_diff in\n Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed\n >|=? fun (ctxt, storage_limit, storage_bus) ->\n let balance_updates = storage_bus @ payload.balance_updates in\n ( ctxt,\n storage_limit,\n Zk_rollup_publish_result {payload with balance_updates} )\n | Zk_rollup_update_result\n ({paid_storage_size_diff; balance_updates; _} as payload) ->\n let consumed = paid_storage_size_diff in\n Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed\n >|=? fun (ctxt, storage_limit, storage_bus) ->\n let balance_updates = storage_bus @ balance_updates in\n ( ctxt,\n storage_limit,\n Zk_rollup_update_result {payload with balance_updates} )\n\n(** [burn_internal_storage_fees ctxt smopr storage_limit payer] burns the\n storage fees associated to an internal operation result [smopr].\n Returns an updated context, an updated storage limit with the space consumed\n by the operation subtracted, and [smopr] with the relevant balance updates\n included. *)\nlet burn_internal_storage_fees :\n type kind.\n context ->\n kind successful_internal_operation_result ->\n storage_limit:Z.t ->\n payer:public_key_hash ->\n (context * Z.t * kind successful_internal_operation_result) tzresult Lwt.t =\n fun ctxt smopr ~storage_limit ~payer ->\n let payer = `Contract (Contract.Implicit payer) in\n match smopr with\n | ITransaction_result transaction_result ->\n burn_transaction_storage_fees\n ctxt\n transaction_result\n ~storage_limit\n ~payer\n >|=? fun (ctxt, storage_limit, transaction_result) ->\n (ctxt, storage_limit, ITransaction_result transaction_result)\n | IOrigination_result origination_result ->\n burn_origination_storage_fees\n ctxt\n origination_result\n ~storage_limit\n ~payer\n >|=? fun (ctxt, storage_limit, origination_result) ->\n (ctxt, storage_limit, IOrigination_result origination_result)\n | IDelegation_result _ -> return (ctxt, storage_limit, smopr)\n | IEvent_result _ -> return (ctxt, storage_limit, smopr)\n\nlet apply_manager_contents (type kind) ctxt chain_id\n (op : kind Kind.manager contents) :\n (success_or_failure\n * kind manager_operation_result\n * packed_internal_operation_result list)\n Lwt.t =\n let (Manager_operation {source; operation; gas_limit; storage_limit; _}) =\n op\n in\n (* We do not expose the internal scaling to the users. Instead, we multiply\n the specified gas limit by the internal scaling. *)\n let ctxt = Gas.set_limit ctxt gas_limit in\n apply_manager_operation ctxt ~source ~chain_id operation >>= function\n | Ok (ctxt, operation_results, internal_operations) -> (\n apply_internal_operations ctxt ~payer:source ~chain_id internal_operations\n >>= function\n | Success ctxt, internal_operations_results -> (\n burn_manager_storage_fees\n ctxt\n operation_results\n ~storage_limit\n ~payer:source\n >>= function\n | Ok (ctxt, storage_limit, operation_results) -> (\n List.fold_left_es\n (fun (ctxt, storage_limit, res) imopr ->\n let (Internal_operation_result (op, mopr)) = imopr in\n match mopr with\n | Applied smopr ->\n burn_internal_storage_fees\n ctxt\n smopr\n ~storage_limit\n ~payer:source\n >>=? fun (ctxt, storage_limit, smopr) ->\n let imopr =\n Internal_operation_result (op, Applied smopr)\n in\n return (ctxt, storage_limit, imopr :: res)\n | _ -> return (ctxt, storage_limit, imopr :: res))\n (ctxt, storage_limit, [])\n internal_operations_results\n >|= function\n | Ok (ctxt, _, internal_operations_results) ->\n ( Success ctxt,\n Applied operation_results,\n List.rev internal_operations_results )\n | Error errors ->\n ( Failure,\n Backtracked (operation_results, Some errors),\n internal_operations_results ))\n | Error errors ->\n Lwt.return\n ( Failure,\n Backtracked (operation_results, Some errors),\n internal_operations_results ))\n | Failure, internal_operations_results ->\n Lwt.return\n (Failure, Applied operation_results, internal_operations_results))\n | Error errors ->\n Lwt.return (Failure, Failed (manager_kind operation, errors), [])\n\n(** An individual manager operation (either standalone or inside a\n batch) together with the balance update corresponding to the\n transfer of its fee. *)\ntype 'kind fees_updated_contents = {\n contents : 'kind contents;\n balance_updates : Receipt.balance_updates;\n}\n\ntype _ fees_updated_contents_list =\n | FeesUpdatedSingle :\n 'kind fees_updated_contents\n -> 'kind fees_updated_contents_list\n | FeesUpdatedCons :\n 'kind Kind.manager fees_updated_contents\n * 'rest Kind.manager fees_updated_contents_list\n -> ('kind * 'rest) Kind.manager fees_updated_contents_list\n\nlet rec mark_skipped :\n type kind.\n payload_producer:Consensus_key.t ->\n Level.t ->\n kind Kind.manager fees_updated_contents_list ->\n kind Kind.manager contents_result_list =\n fun ~payload_producer level fees_updated_contents_list ->\n match fees_updated_contents_list with\n | FeesUpdatedSingle\n {contents = Manager_operation {operation; _}; balance_updates} ->\n Single_result\n (Manager_operation_result\n {\n balance_updates;\n operation_result = Skipped (manager_kind operation);\n internal_operation_results = [];\n })\n | FeesUpdatedCons\n ({contents = Manager_operation {operation; _}; balance_updates}, rest) ->\n Cons_result\n ( Manager_operation_result\n {\n balance_updates;\n operation_result = Skipped (manager_kind operation);\n internal_operation_results = [];\n },\n mark_skipped ~payload_producer level rest )\n\n(** Return balance updates for fees, and an updated context that\n accounts for:\n\n - fees spending,\n\n - counter incrementation,\n\n - consumption of each operation's [gas_limit] from the available\n block gas.\n\n The operation should already have been validated by\n {!Validate.validate_operation}. The latter is responsible for ensuring that\n the operation is solvable, i.e. its fees can be taken, i.e.\n [take_fees] cannot return an error. *)\nlet take_fees ctxt contents_list =\n let open Lwt_result_syntax in\n let rec take_fees_rec :\n type kind.\n context ->\n kind Kind.manager contents_list ->\n (context * kind Kind.manager fees_updated_contents_list) tzresult Lwt.t =\n fun ctxt contents_list ->\n let contents_effects contents =\n let (Manager_operation {source; fee; gas_limit; _}) = contents in\n let*? ctxt = Gas.consume_limit_in_block ctxt gas_limit in\n let* ctxt = Contract.increment_counter ctxt source in\n let+ ctxt, balance_updates =\n Token.transfer\n ctxt\n (`Contract (Contract.Implicit source))\n `Block_fees\n fee\n in\n (ctxt, {contents; balance_updates})\n in\n match contents_list with\n | Single contents ->\n let+ ctxt, fees_updated_contents = contents_effects contents in\n (ctxt, FeesUpdatedSingle fees_updated_contents)\n | Cons (contents, rest) ->\n let* ctxt, fees_updated_contents = contents_effects contents in\n let+ ctxt, result_rest = take_fees_rec ctxt rest in\n (ctxt, FeesUpdatedCons (fees_updated_contents, result_rest))\n in\n let*! result = take_fees_rec ctxt contents_list in\n Lwt.return (record_trace Error_while_taking_fees result)\n\nlet rec apply_manager_contents_list_rec :\n type kind.\n context ->\n payload_producer:Consensus_key.t ->\n Chain_id.t ->\n kind Kind.manager fees_updated_contents_list ->\n (success_or_failure * kind Kind.manager contents_result_list) Lwt.t =\n fun ctxt ~payload_producer chain_id fees_updated_contents_list ->\n let level = Level.current ctxt in\n match fees_updated_contents_list with\n | FeesUpdatedSingle {contents = Manager_operation _ as op; balance_updates} ->\n apply_manager_contents ctxt chain_id op\n >|= fun (ctxt_result, operation_result, internal_operation_results) ->\n let result =\n Manager_operation_result\n {balance_updates; operation_result; internal_operation_results}\n in\n (ctxt_result, Single_result result)\n | FeesUpdatedCons\n ({contents = Manager_operation _ as op; balance_updates}, rest) -> (\n apply_manager_contents ctxt chain_id op >>= function\n | Failure, operation_result, internal_operation_results ->\n let result =\n Manager_operation_result\n {balance_updates; operation_result; internal_operation_results}\n in\n Lwt.return\n ( Failure,\n Cons_result (result, mark_skipped ~payload_producer level rest) )\n | Success ctxt, operation_result, internal_operation_results ->\n let result =\n Manager_operation_result\n {balance_updates; operation_result; internal_operation_results}\n in\n apply_manager_contents_list_rec ctxt ~payload_producer chain_id rest\n >|= fun (ctxt_result, results) ->\n (ctxt_result, Cons_result (result, results)))\n\nlet mark_backtracked results =\n let mark_results :\n type kind.\n kind Kind.manager contents_result -> kind Kind.manager contents_result =\n fun results ->\n let mark_manager_operation_result :\n type kind.\n kind manager_operation_result -> kind manager_operation_result =\n function\n | (Failed _ | Skipped _ | Backtracked _) as result -> result\n | Applied result -> Backtracked (result, None)\n in\n let mark_internal_operation_result :\n type kind.\n kind internal_operation_result -> kind internal_operation_result =\n function\n | (Failed _ | Skipped _ | Backtracked _) as result -> result\n | Applied result -> Backtracked (result, None)\n in\n let mark_internal_operation_results\n (Internal_operation_result (kind, result)) =\n Internal_operation_result (kind, mark_internal_operation_result result)\n in\n match results with\n | Manager_operation_result op ->\n Manager_operation_result\n {\n balance_updates = op.balance_updates;\n operation_result = mark_manager_operation_result op.operation_result;\n internal_operation_results =\n List.map\n mark_internal_operation_results\n op.internal_operation_results;\n }\n in\n let rec traverse_apply_results :\n type kind.\n kind Kind.manager contents_result_list ->\n kind Kind.manager contents_result_list = function\n | Single_result res -> Single_result (mark_results res)\n | Cons_result (res, rest) ->\n Cons_result (mark_results res, traverse_apply_results rest)\n in\n traverse_apply_results results\n\ntype mode =\n | Application of {\n block_header : Block_header.t;\n fitness : Fitness.t;\n payload_producer : Consensus_key.t;\n block_producer : Consensus_key.t;\n predecessor_level : Level.t;\n predecessor_round : Round.t;\n }\n | Full_construction of {\n block_data_contents : Block_header.contents;\n predecessor_hash : Block_hash.t;\n payload_producer : Consensus_key.t;\n block_producer : Consensus_key.t;\n round : Round.t;\n predecessor_level : Level.t;\n predecessor_round : Round.t;\n }\n | Partial_construction of {\n predecessor_level : Raw_level.t;\n predecessor_fitness : Fitness.raw;\n }\n\ntype application_state = {\n ctxt : t;\n chain_id : Chain_id.t;\n mode : mode;\n op_count : int;\n migration_balance_updates : Receipt.balance_updates;\n liquidity_baking_toggle_ema : Liquidity_baking.Toggle_EMA.t;\n implicit_operations_results :\n Apply_results.packed_successful_manager_operation_result list;\n}\n\nlet record_operation (type kind) ctxt hash (operation : kind operation) :\n context =\n match operation.protocol_data.contents with\n | Single (Preendorsement _) -> ctxt\n | Single (Endorsement _) -> ctxt\n | Single (Dal_attestation _) -> ctxt\n | Single\n ( Failing_noop _ | Proposals _ | Ballot _ | Seed_nonce_revelation _\n | Vdf_revelation _ | Double_endorsement_evidence _\n | Double_preendorsement_evidence _ | Double_baking_evidence _\n | Activate_account _ | Drain_delegate _ | Manager_operation _ )\n | Cons (Manager_operation _, _) ->\n record_non_consensus_operation_hash ctxt hash\n\nlet record_preendorsement ctxt (mode : mode) (content : consensus_content) :\n (context * Kind.preendorsement contents_result_list) tzresult =\n let open Result_syntax in\n let ctxt =\n match mode with\n | Full_construction _ -> (\n match Consensus.get_preendorsements_quorum_round ctxt with\n | None -> Consensus.set_preendorsements_quorum_round ctxt content.round\n | Some _ -> ctxt)\n | Application _ | Partial_construction _ -> ctxt\n in\n match Slot.Map.find content.slot (Consensus.allowed_preendorsements ctxt) with\n | None ->\n (* This should not happen: operation validation should have failed. *)\n error Faulty_validation_wrong_slot\n | Some ({delegate; consensus_pkh; _}, preendorsement_power) ->\n let* ctxt =\n Consensus.record_preendorsement\n ctxt\n ~initial_slot:content.slot\n ~power:preendorsement_power\n content.round\n in\n return\n ( ctxt,\n Single_result\n (Preendorsement_result\n {\n balance_updates = [];\n delegate;\n consensus_key = consensus_pkh;\n preendorsement_power;\n }) )\n\nlet is_grandparent_endorsement mode content =\n match mode with\n | Partial_construction {predecessor_level; _} ->\n Raw_level.(succ content.level = predecessor_level)\n | _ -> false\n\nlet record_endorsement ctxt (mode : mode) (content : consensus_content) :\n (context * Kind.endorsement contents_result_list) tzresult Lwt.t =\n let open Lwt_result_syntax in\n let mk_endorsement_result {Consensus_key.delegate; consensus_pkh}\n endorsement_power =\n Single_result\n (Endorsement_result\n {\n balance_updates = [];\n delegate;\n consensus_key = consensus_pkh;\n endorsement_power;\n })\n in\n if is_grandparent_endorsement mode content then\n let level = Level.from_raw ctxt content.level in\n let* ctxt, ({delegate; _} as consensus_key) =\n Stake_distribution.slot_owner ctxt level content.slot\n in\n let*? ctxt = Consensus.record_grand_parent_endorsement ctxt delegate in\n return (ctxt, mk_endorsement_result (Consensus_key.pkh consensus_key) 0)\n else\n match Slot.Map.find content.slot (Consensus.allowed_endorsements ctxt) with\n | None ->\n (* This should not happen: operation validation should have failed. *)\n tzfail Faulty_validation_wrong_slot\n | Some (consensus_key, power) ->\n let*? ctxt =\n Consensus.record_endorsement ctxt ~initial_slot:content.slot ~power\n in\n return\n (ctxt, mk_endorsement_result (Consensus_key.pkh consensus_key) power)\n\nlet apply_manager_contents_list ctxt ~payload_producer chain_id\n fees_updated_contents_list =\n apply_manager_contents_list_rec\n ctxt\n ~payload_producer\n chain_id\n fees_updated_contents_list\n >>= fun (ctxt_result, results) ->\n match ctxt_result with\n | Failure -> Lwt.return (ctxt (* backtracked *), mark_backtracked results)\n | Success ctxt ->\n Lazy_storage.cleanup_temporaries ctxt >|= fun ctxt -> (ctxt, results)\n\nlet apply_manager_operations ctxt ~payload_producer chain_id ~mempool_mode\n contents_list =\n let open Lwt_result_syntax in\n let ctxt = if mempool_mode then Gas.reset_block_gas ctxt else ctxt in\n let* ctxt, fees_updated_contents_list = take_fees ctxt contents_list in\n let*! ctxt, contents_result_list =\n apply_manager_contents_list\n ctxt\n ~payload_producer\n chain_id\n fees_updated_contents_list\n in\n return (ctxt, contents_result_list)\n\nlet punish_delegate ctxt delegate level mistake mk_result ~payload_producer =\n let punish =\n match mistake with\n | `Double_baking -> Delegate.punish_double_baking\n | `Double_endorsing -> Delegate.punish_double_endorsing\n in\n punish ctxt delegate level >>=? fun (ctxt, burned, punish_balance_updates) ->\n (match Tez.(burned /? 2L) with\n | Ok reward ->\n Token.transfer\n ctxt\n `Double_signing_evidence_rewards\n (`Contract (Contract.Implicit payload_producer.Consensus_key.delegate))\n reward\n | Error _ -> (* reward is Tez.zero *) return (ctxt, []))\n >|=? fun (ctxt, reward_balance_updates) ->\n let balance_updates = reward_balance_updates @ punish_balance_updates in\n (ctxt, Single_result (mk_result balance_updates))\n\nlet punish_double_endorsement_or_preendorsement (type kind) ctxt\n ~(op1 : kind Kind.consensus Operation.t) ~payload_producer :\n (context\n * kind Kind.double_consensus_operation_evidence contents_result_list)\n tzresult\n Lwt.t =\n let mk_result (balance_updates : Receipt.balance_updates) :\n kind Kind.double_consensus_operation_evidence contents_result =\n match op1.protocol_data.contents with\n | Single (Preendorsement _) ->\n Double_preendorsement_evidence_result balance_updates\n | Single (Endorsement _) ->\n Double_endorsement_evidence_result balance_updates\n in\n match op1.protocol_data.contents with\n | Single (Preendorsement e1) | Single (Endorsement e1) ->\n let level = Level.from_raw ctxt e1.level in\n Stake_distribution.slot_owner ctxt level e1.slot\n >>=? fun (ctxt, consensus_pk1) ->\n punish_delegate\n ctxt\n consensus_pk1.delegate\n level\n `Double_endorsing\n mk_result\n ~payload_producer\n\nlet punish_double_baking ctxt (bh1 : Block_header.t) ~payload_producer =\n Fitness.from_raw bh1.shell.fitness >>?= fun bh1_fitness ->\n let round1 = Fitness.round bh1_fitness in\n Raw_level.of_int32 bh1.shell.level >>?= fun raw_level ->\n let level = Level.from_raw ctxt raw_level in\n let committee_size = Constants.consensus_committee_size ctxt in\n Round.to_slot round1 ~committee_size >>?= fun slot1 ->\n Stake_distribution.slot_owner ctxt level slot1\n >>=? fun (ctxt, consensus_pk1) ->\n punish_delegate\n ctxt\n consensus_pk1.delegate\n level\n `Double_baking\n ~payload_producer\n (fun balance_updates -> Double_baking_evidence_result balance_updates)\n\nlet apply_contents_list (type kind) ctxt chain_id (mode : mode)\n ~payload_producer (contents_list : kind contents_list) :\n (context * kind contents_result_list) tzresult Lwt.t =\n let mempool_mode =\n match mode with\n | Partial_construction _ -> true\n | Full_construction _ | Application _ -> false\n in\n match contents_list with\n | Single (Preendorsement consensus_content) ->\n record_preendorsement ctxt mode consensus_content |> Lwt.return\n | Single (Endorsement consensus_content) ->\n record_endorsement ctxt mode consensus_content\n | Single (Dal_attestation op) ->\n (* DAL/FIXME https://gitlab.com/tezos/tezos/-/issues/3115\n\n This is a temporary operation. We do no check for the\n moment. In particular, this means we do not check the\n signature. Consequently, it is really important to ensure this\n operation cannot be included into a block when the feature flag\n is not set. This is done in order to avoid modifying the\n endorsement encoding. However, once the DAL will be ready, this\n operation should be merged with an endorsement or at least\n refined. *)\n Dal_apply.apply_attestation ctxt op >>?= fun ctxt ->\n return\n (ctxt, Single_result (Dal_attestation_result {delegate = op.attestor}))\n | Single (Seed_nonce_revelation {level; nonce}) ->\n let level = Level.from_raw ctxt level in\n Nonce.reveal ctxt level nonce >>=? fun ctxt ->\n let tip = Constants.seed_nonce_revelation_tip ctxt in\n let contract =\n Contract.Implicit payload_producer.Consensus_key.delegate\n in\n Token.transfer ctxt `Revelation_rewards (`Contract contract) tip\n >|=? fun (ctxt, balance_updates) ->\n (ctxt, Single_result (Seed_nonce_revelation_result balance_updates))\n | Single (Vdf_revelation {solution}) ->\n Seed.update_seed ctxt solution >>=? fun ctxt ->\n let tip = Constants.seed_nonce_revelation_tip ctxt in\n let contract =\n Contract.Implicit payload_producer.Consensus_key.delegate\n in\n Token.transfer ctxt `Revelation_rewards (`Contract contract) tip\n >|=? fun (ctxt, balance_updates) ->\n (ctxt, Single_result (Vdf_revelation_result balance_updates))\n | Single (Double_preendorsement_evidence {op1; op2 = _}) ->\n punish_double_endorsement_or_preendorsement ctxt ~op1 ~payload_producer\n | Single (Double_endorsement_evidence {op1; op2 = _}) ->\n punish_double_endorsement_or_preendorsement ctxt ~op1 ~payload_producer\n | Single (Double_baking_evidence {bh1; bh2 = _}) ->\n punish_double_baking ctxt bh1 ~payload_producer\n | Single (Activate_account {id = pkh; activation_code}) ->\n let blinded_pkh =\n Blinded_public_key_hash.of_ed25519_pkh activation_code pkh\n in\n let src = `Collected_commitments blinded_pkh in\n let contract = Contract.Implicit (Signature.Ed25519 pkh) in\n Token.balance ctxt src >>=? fun (ctxt, amount) ->\n Token.transfer ctxt src (`Contract contract) amount\n >>=? fun (ctxt, bupds) ->\n return (ctxt, Single_result (Activate_account_result bupds))\n | Single (Proposals _ as contents) ->\n Amendment.apply_proposals ctxt chain_id contents\n | Single (Ballot _ as contents) -> Amendment.apply_ballot ctxt contents\n | Single (Drain_delegate {delegate; destination; consensus_key = _}) ->\n Delegate.drain ctxt ~delegate ~destination\n >>=? fun ( ctxt,\n allocated_destination_contract,\n fees,\n drain_balance_updates ) ->\n Token.transfer\n ctxt\n (`Contract (Contract.Implicit delegate))\n (`Contract (Contract.Implicit payload_producer.Consensus_key.delegate))\n fees\n >>=? fun (ctxt, fees_balance_updates) ->\n let balance_updates = drain_balance_updates @ fees_balance_updates in\n return\n ( ctxt,\n Single_result\n (Drain_delegate_result\n {balance_updates; allocated_destination_contract}) )\n | Single (Failing_noop _) ->\n (* This operation always fails. It should already have been\n rejected by {!Validate.validate_operation}. *)\n tzfail Validate_errors.Failing_noop_error\n | Single (Manager_operation _) ->\n apply_manager_operations\n ctxt\n ~payload_producer\n chain_id\n ~mempool_mode\n contents_list\n | Cons (Manager_operation _, _) ->\n apply_manager_operations\n ctxt\n ~payload_producer\n chain_id\n ~mempool_mode\n contents_list\n\nlet apply_operation application_state operation_hash operation =\n let open Lwt_result_syntax in\n let apply_operation application_state packed_operation ~payload_producer =\n let {shell; protocol_data = Operation_data unpacked_protocol_data} =\n packed_operation\n in\n let operation : _ Operation.t =\n {shell; protocol_data = unpacked_protocol_data}\n in\n let ctxt = Origination_nonce.init application_state.ctxt operation_hash in\n let ctxt = record_operation ctxt operation_hash operation in\n let* ctxt, result =\n apply_contents_list\n ctxt\n application_state.chain_id\n application_state.mode\n ~payload_producer\n operation.protocol_data.contents\n in\n let ctxt = Gas.set_unlimited ctxt in\n let ctxt = Origination_nonce.unset ctxt in\n let op_count = succ application_state.op_count in\n return\n ( {application_state with ctxt; op_count},\n Operation_metadata {contents = result} )\n in\n match application_state.mode with\n | Application {payload_producer; _} ->\n apply_operation application_state operation ~payload_producer\n | Full_construction {payload_producer; _} ->\n apply_operation application_state operation ~payload_producer\n | Partial_construction _ ->\n apply_operation\n application_state\n operation\n ~payload_producer:Consensus_key.zero\n\nlet may_start_new_cycle ctxt =\n match Level.dawn_of_a_new_cycle ctxt with\n | None -> return (ctxt, [], [])\n | Some last_cycle ->\n Delegate.cycle_end ctxt last_cycle\n >>=? fun (ctxt, balance_updates, deactivated) ->\n Bootstrap.cycle_end ctxt last_cycle >|=? fun ctxt ->\n (ctxt, balance_updates, deactivated)\n\nlet apply_liquidity_baking_subsidy ctxt ~toggle_vote =\n Liquidity_baking.on_subsidy_allowed\n ctxt\n ~toggle_vote\n (fun ctxt liquidity_baking_cpmm_contract_hash ->\n let liquidity_baking_cpmm_contract =\n Contract.Originated liquidity_baking_cpmm_contract_hash\n in\n let ctxt =\n (* We set a gas limit of 1/20th the block limit, which is ~10x\n actual usage here in Granada. Gas consumed is reported in\n the Transaction receipt, but not counted towards the block\n limit. The gas limit is reset to unlimited at the end of\n this function.*)\n Gas.set_limit\n ctxt\n (Gas.Arith.integral_exn\n (Z.div\n (Gas.Arith.integral_to_z\n (Constants.hard_gas_limit_per_block ctxt))\n (Z.of_int 20)))\n in\n let backtracking_ctxt = ctxt in\n (let liquidity_baking_subsidy = Constants.liquidity_baking_subsidy ctxt in\n (* credit liquidity baking subsidy to CPMM contract *)\n Token.transfer\n ~origin:Subsidy\n ctxt\n `Liquidity_baking_subsidies\n (`Contract liquidity_baking_cpmm_contract)\n liquidity_baking_subsidy\n >>=? fun (ctxt, balance_updates) ->\n Script_cache.find ctxt liquidity_baking_cpmm_contract_hash\n >>=? fun (ctxt, cache_key, script) ->\n match script with\n | None -> tzfail (Script_tc_errors.No_such_entrypoint Entrypoint.default)\n | Some (script, script_ir) -> (\n (* Token.transfer which is being called above already loads this\n value into the Irmin cache, so no need to burn gas for it. *)\n Contract.get_balance ctxt liquidity_baking_cpmm_contract\n >>=? fun balance ->\n let now = Script_timestamp.now ctxt in\n let level =\n (Level.current ctxt).level |> Raw_level.to_int32\n |> Script_int.of_int32 |> Script_int.abs\n in\n let step_constants =\n let open Script_interpreter in\n (* Using dummy values for source, payer, and chain_id\n since they are not used within the CPMM default\n entrypoint. *)\n {\n source = Destination.Contract liquidity_baking_cpmm_contract;\n payer = Signature.Public_key_hash.zero;\n self = liquidity_baking_cpmm_contract_hash;\n amount = liquidity_baking_subsidy;\n balance;\n chain_id = Chain_id.zero;\n now;\n level;\n }\n in\n (*\n Call CPPM default entrypoint with parameter Unit.\n This is necessary for the CPMM's xtz_pool in storage to\n increase since it cannot use BALANCE due to a transfer attack.\n\n Mimicks a transaction.\n\n There is no:\n - storage burn (extra storage is free)\n - fees (the operation is mandatory)\n *)\n Script_interpreter.execute_with_typed_parameter\n ctxt\n Optimized\n step_constants\n ~script\n ~parameter:()\n ~parameter_ty:Unit_t\n ~cached_script:(Some script_ir)\n ~location:Micheline.dummy_location\n ~entrypoint:Entrypoint.default\n ~internal:false\n >>=? fun ( {\n script = updated_cached_script;\n code_size = updated_size;\n storage;\n lazy_storage_diff;\n operations;\n ticket_diffs;\n ticket_receipt;\n },\n ctxt ) ->\n match operations with\n | _ :: _ ->\n (* No internal operations are expected here. Something bad may be happening. *)\n return (backtracking_ctxt, [])\n | [] ->\n (* update CPMM storage *)\n update_script_storage_and_ticket_balances\n ctxt\n ~self_contract:liquidity_baking_cpmm_contract_hash\n storage\n lazy_storage_diff\n ticket_diffs\n operations\n >>=? fun (ticket_table_size_diff, ctxt) ->\n Fees.record_paid_storage_space\n ctxt\n liquidity_baking_cpmm_contract_hash\n >>=? fun (ctxt, new_size, paid_storage_size_diff) ->\n Ticket_balance.adjust_storage_space\n ctxt\n ~storage_diff:ticket_table_size_diff\n >>=? fun (ticket_paid_storage_diff, ctxt) ->\n let consumed_gas =\n Gas.consumed ~since:backtracking_ctxt ~until:ctxt\n in\n Script_cache.update\n ctxt\n cache_key\n ( {script with storage = Script.lazy_expr storage},\n updated_cached_script )\n updated_size\n >>?= fun ctxt ->\n let result =\n Transaction_result\n (Transaction_to_contract_result\n {\n storage = Some storage;\n lazy_storage_diff;\n balance_updates;\n ticket_receipt;\n (* At this point in application the\n origination nonce has not been initialized\n so it's not possible to originate new\n contracts. We've checked above that none\n were originated. *)\n originated_contracts = [];\n consumed_gas;\n storage_size = new_size;\n paid_storage_size_diff =\n Z.add paid_storage_size_diff ticket_paid_storage_diff;\n allocated_destination_contract = false;\n })\n in\n let ctxt = Gas.set_unlimited ctxt in\n return (ctxt, [Successful_manager_result result])))\n >|= function\n | Ok (ctxt, results) -> Ok (ctxt, results)\n | Error _ ->\n (* Do not fail if something bad happens during CPMM contract call. *)\n let ctxt = Gas.set_unlimited backtracking_ctxt in\n Ok (ctxt, []))\n\nlet are_endorsements_required ctxt ~level =\n First_level_of_protocol.get ctxt >|=? fun first_level ->\n (* NB: the first level is the level of the migration block. There\n are no endorsements for this block. Therefore the block at the\n next level cannot contain endorsements. *)\n let level_position_in_protocol = Raw_level.diff level first_level in\n Compare.Int32.(level_position_in_protocol > 1l)\n\nlet record_endorsing_participation ctxt =\n let validators = Consensus.allowed_endorsements ctxt in\n Slot.Map.fold_es\n (fun initial_slot ((consensus_pk : Consensus_key.pk), power) ctxt ->\n let participation =\n if Slot.Set.mem initial_slot (Consensus.endorsements_seen ctxt) then\n Delegate.Participated\n else Delegate.Didn't_participate\n in\n Delegate.record_endorsing_participation\n ctxt\n ~delegate:consensus_pk.delegate\n ~participation\n ~endorsing_power:power)\n validators\n ctxt\n\nlet begin_application ctxt chain_id ~migration_balance_updates\n ~migration_operation_results ~(predecessor_fitness : Fitness.raw)\n (block_header : Block_header.t) : application_state tzresult Lwt.t =\n let open Lwt_result_syntax in\n let*? fitness = Fitness.from_raw block_header.shell.fitness in\n let level = block_header.shell.level in\n let*? predecessor_round = Fitness.round_from_raw predecessor_fitness in\n let*? predecessor_level = Raw_level.of_int32 (Int32.pred level) in\n let predecessor_level = Level.from_raw ctxt predecessor_level in\n let round = Fitness.round fitness in\n let current_level = Level.current ctxt in\n let* ctxt, _slot, block_producer =\n Stake_distribution.baking_rights_owner ctxt current_level ~round\n in\n let* ctxt, _slot, payload_producer =\n Stake_distribution.baking_rights_owner\n ctxt\n current_level\n ~round:block_header.protocol_data.contents.payload_round\n in\n let toggle_vote =\n block_header.Block_header.protocol_data.contents\n .liquidity_baking_toggle_vote\n in\n let* ctxt, liquidity_baking_operations_results, liquidity_baking_toggle_ema =\n apply_liquidity_baking_subsidy ctxt ~toggle_vote\n in\n let*! ctxt =\n Sc_rollup.Inbox.add_info_per_level\n ~predecessor:block_header.shell.predecessor\n ctxt\n in\n let mode =\n Application\n {\n block_header;\n fitness;\n predecessor_round;\n predecessor_level;\n payload_producer = Consensus_key.pkh payload_producer;\n block_producer = Consensus_key.pkh block_producer;\n }\n in\n return\n {\n mode;\n chain_id;\n ctxt;\n op_count = 0;\n migration_balance_updates;\n liquidity_baking_toggle_ema;\n implicit_operations_results =\n Apply_results.pack_migration_operation_results\n migration_operation_results\n @ liquidity_baking_operations_results;\n }\n\nlet begin_full_construction ctxt chain_id ~migration_balance_updates\n ~migration_operation_results ~predecessor_timestamp ~predecessor_level\n ~predecessor_round ~predecessor_hash ~timestamp\n (block_data_contents : Block_header.contents) =\n let open Lwt_result_syntax in\n let round_durations = Constants.round_durations ctxt in\n let*? round =\n Round.round_of_timestamp\n round_durations\n ~predecessor_timestamp\n ~predecessor_round\n ~timestamp\n in\n (* The endorsement/preendorsement validation rules for construction are the\n same as for application. *)\n let current_level = Level.current ctxt in\n let* ctxt, _slot, block_producer =\n Stake_distribution.baking_rights_owner ctxt current_level ~round\n in\n let* ctxt, _slot, payload_producer =\n Stake_distribution.baking_rights_owner\n ctxt\n current_level\n ~round:block_data_contents.payload_round\n in\n let toggle_vote = block_data_contents.liquidity_baking_toggle_vote in\n let* ctxt, liquidity_baking_operations_results, liquidity_baking_toggle_ema =\n apply_liquidity_baking_subsidy ctxt ~toggle_vote\n in\n let*! ctxt =\n Sc_rollup.Inbox.add_info_per_level ~predecessor:predecessor_hash ctxt\n in\n let mode =\n Full_construction\n {\n block_data_contents;\n predecessor_hash;\n payload_producer = Consensus_key.pkh payload_producer;\n block_producer = Consensus_key.pkh block_producer;\n round;\n predecessor_round;\n predecessor_level;\n }\n in\n return\n {\n mode;\n chain_id;\n ctxt;\n op_count = 0;\n migration_balance_updates;\n liquidity_baking_toggle_ema;\n implicit_operations_results =\n Apply_results.pack_migration_operation_results\n migration_operation_results\n @ liquidity_baking_operations_results;\n }\n\nlet begin_partial_construction ctxt chain_id ~migration_balance_updates\n ~migration_operation_results ~predecessor_level ~predecessor_hash\n ~(predecessor_fitness : Fitness.raw) : application_state tzresult Lwt.t =\n let open Lwt_result_syntax in\n let toggle_vote = Liquidity_baking.LB_pass in\n let* ctxt, liquidity_baking_operations_results, liquidity_baking_toggle_ema =\n apply_liquidity_baking_subsidy ctxt ~toggle_vote\n in\n let* ctxt =\n (* The mode [Partial_construction] is used in simulation. We try to\n put a realistic value of the block's timestamp. Even though, it should\n not have an impact on the simulation of the following smart rollup\n operations.\n *)\n let predecessor = predecessor_hash in\n let*! ctxt = Sc_rollup.Inbox.add_info_per_level ~predecessor ctxt in\n return ctxt\n in\n let mode = Partial_construction {predecessor_level; predecessor_fitness} in\n return\n {\n mode;\n chain_id;\n ctxt;\n op_count = 0;\n migration_balance_updates;\n liquidity_baking_toggle_ema;\n implicit_operations_results =\n Apply_results.pack_migration_operation_results\n migration_operation_results\n @ liquidity_baking_operations_results;\n }\n\nlet finalize_application ctxt block_data_contents ~round ~predecessor_hash\n ~liquidity_baking_toggle_ema ~implicit_operations_results\n ~migration_balance_updates ~(block_producer : Consensus_key.t)\n ~(payload_producer : Consensus_key.t) =\n let open Lwt_result_syntax in\n let level = Level.current ctxt in\n let endorsing_power = Consensus.current_endorsement_power ctxt in\n let* required_endorsements =\n are_endorsements_required ctxt ~level:level.level\n in\n let block_payload_hash =\n Block_payload.hash\n ~predecessor_hash\n ~payload_round:block_data_contents.Block_header.payload_round\n (non_consensus_operations ctxt)\n in\n (* from this point nothing should fail *)\n (* We mark the endorsement branch as the grand parent branch when\n accessible. This will not be present before the first two blocks\n of tenderbake. *)\n let level = Level.current ctxt in\n let*! ctxt =\n match Consensus.endorsement_branch ctxt with\n | Some predecessor_branch ->\n Consensus.store_grand_parent_branch ctxt predecessor_branch\n | None -> Lwt.return ctxt\n in\n (* We mark the current payload hash as the predecessor one => this\n will only be accessed by the successor block now. *)\n let*! ctxt =\n Consensus.store_endorsement_branch\n ctxt\n (predecessor_hash, block_payload_hash)\n in\n let* ctxt = Round.update ctxt round in\n (* end of level *)\n let* ctxt =\n match block_data_contents.Block_header.seed_nonce_hash with\n | None -> return ctxt\n | Some nonce_hash ->\n Nonce.record_hash ctxt {nonce_hash; delegate = block_producer.delegate}\n in\n let* ctxt, reward_bonus =\n if required_endorsements then\n let* ctxt = record_endorsing_participation ctxt in\n let*? rewards_bonus = Baking.bonus_baking_reward ctxt ~endorsing_power in\n return (ctxt, Some rewards_bonus)\n else return (ctxt, None)\n in\n let baking_reward = Constants.baking_reward_fixed_portion ctxt in\n let* ctxt, baking_receipts =\n Delegate.record_baking_activity_and_pay_rewards_and_fees\n ctxt\n ~payload_producer:payload_producer.delegate\n ~block_producer:block_producer.delegate\n ~baking_reward\n ~reward_bonus\n in\n (* if end of nonce revelation period, compute seed *)\n let* ctxt =\n if Level.may_compute_randao ctxt then Seed.compute_randao ctxt\n else return ctxt\n in\n let* ctxt =\n if Level.may_snapshot_stake_distribution ctxt then\n Stake_distribution.snapshot ctxt\n else return ctxt\n in\n let* ctxt, cycle_end_balance_updates, deactivated =\n may_start_new_cycle ctxt\n in\n let* ctxt = Amendment.may_start_new_voting_period ctxt in\n let* ctxt, dal_attestation = Dal_apply.finalisation ctxt in\n let*! ctxt = Sc_rollup.Inbox.finalize_inbox_level ctxt in\n let balance_updates =\n migration_balance_updates @ baking_receipts @ cycle_end_balance_updates\n in\n let consumed_gas =\n Gas.Arith.sub\n (Gas.Arith.fp @@ Constants.hard_gas_limit_per_block ctxt)\n (Gas.block_level ctxt)\n in\n let+ voting_period_info = Voting_period.get_rpc_current_info ctxt in\n let receipt =\n Apply_results.\n {\n proposer = payload_producer;\n baker = block_producer;\n level_info = level;\n voting_period_info;\n nonce_hash = block_data_contents.seed_nonce_hash;\n consumed_gas;\n deactivated;\n balance_updates;\n liquidity_baking_toggle_ema;\n implicit_operations_results;\n dal_attestation;\n }\n in\n (ctxt, receipt)\n\ntype error += Missing_shell_header\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"apply.missing_shell_header\"\n ~title:\"Missing shell_header during finalisation of a block\"\n ~description:\n \"During finalisation of a block header in Application mode or Full \\\n construction mode, a shell header should be provided so that a cache \\\n nonce can be computed.\"\n ~pp:(fun ppf () ->\n Format.fprintf\n ppf\n \"No shell header provided during the finalisation of a block.\")\n Data_encoding.unit\n (function Missing_shell_header -> Some () | _ -> None)\n (fun () -> Missing_shell_header)\n\nlet finalize_with_commit_message ctxt ~cache_nonce fitness round op_count =\n let open Lwt_syntax in\n let* ctxt = Cache.Admin.sync ctxt cache_nonce in\n let raw_level = Raw_level.to_int32 (Level.current ctxt).level in\n let commit_message =\n Format.asprintf\n \"lvl %ld, fit:%a, round %a, %d ops\"\n raw_level\n Fitness.pp\n fitness\n Round.pp\n round\n op_count\n in\n let validation_result =\n finalize ~commit_message ctxt (Fitness.to_raw fitness)\n in\n return validation_result\n\nlet finalize_block (application_state : application_state) shell_header_opt =\n let open Lwt_result_syntax in\n let {\n ctxt;\n liquidity_baking_toggle_ema;\n implicit_operations_results;\n migration_balance_updates;\n op_count;\n _;\n } =\n application_state\n in\n match application_state.mode with\n | Full_construction\n {\n block_data_contents;\n predecessor_hash;\n predecessor_level = _;\n predecessor_round;\n block_producer;\n payload_producer;\n round;\n } ->\n let*? (shell_header : Block_header.shell_header) =\n Option.value_e\n shell_header_opt\n ~error:(Error_monad.trace_of_error Missing_shell_header)\n in\n let cache_nonce =\n Cache.cache_nonce_from_block_header shell_header block_data_contents\n in\n let locked_round_evidence =\n Option.map\n (fun (preendorsement_round, preendorsement_count) ->\n Block_header.{preendorsement_round; preendorsement_count})\n (Consensus.locked_round_evidence ctxt)\n in\n let locked_round =\n match locked_round_evidence with\n | None -> None\n | Some {preendorsement_round; _} -> Some preendorsement_round\n in\n let level = (Level.current ctxt).level in\n let*? fitness =\n Fitness.create ~level ~round ~predecessor_round ~locked_round\n in\n let* ctxt, receipt =\n finalize_application\n ctxt\n block_data_contents\n ~round\n ~predecessor_hash\n ~liquidity_baking_toggle_ema\n ~implicit_operations_results\n ~migration_balance_updates\n ~block_producer\n ~payload_producer\n in\n let*! result =\n finalize_with_commit_message ctxt ~cache_nonce fitness round op_count\n in\n return (result, receipt)\n | Partial_construction {predecessor_fitness; _} ->\n let* voting_period_info = Voting_period.get_rpc_current_info ctxt in\n let level_info = Level.current ctxt in\n let result = finalize ctxt predecessor_fitness in\n return\n ( result,\n Apply_results.\n {\n proposer = Consensus_key.zero;\n baker = Consensus_key.zero;\n level_info;\n voting_period_info;\n nonce_hash = None;\n consumed_gas = Gas.Arith.zero;\n deactivated = [];\n balance_updates = migration_balance_updates;\n liquidity_baking_toggle_ema;\n implicit_operations_results;\n dal_attestation = None;\n } )\n | Application\n {\n fitness;\n block_header = {shell; protocol_data};\n payload_producer;\n block_producer;\n _;\n } ->\n let round = Fitness.round fitness in\n let cache_nonce =\n Cache.cache_nonce_from_block_header shell protocol_data.contents\n in\n let* ctxt, receipt =\n finalize_application\n ctxt\n protocol_data.contents\n ~round\n ~predecessor_hash:shell.predecessor\n ~liquidity_baking_toggle_ema\n ~implicit_operations_results\n ~migration_balance_updates\n ~block_producer\n ~payload_producer\n in\n let*! result =\n finalize_with_commit_message ctxt ~cache_nonce fitness round op_count\n in\n return (result, receipt)\n\nlet value_of_key ctxt k = Cache.Admin.value_of_key ctxt k\n" ;
} ;
{ name = "Services_registration" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020-2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Functions for RPC service registration, using [Updater.rpc_context] and\n [RPC_service.t] from the Protocol Environment.\n\n This module is a frontend to a mutable service directory. The various\n [register] functions update the directory as a side-effect.\n\n The [get_rpc_services] function returns the resulting [RPC_context]. It is\n parameterized by [Updater.rpc_context] which acts as the service prefix (in\n practice meaning this type will be passed to each handler). Hence,\n Protocol RPC services provide a {i read-only} view of the Ledger state.\n *)\n\nopen Alpha_context\n\ntype rpc_context = {\n block_hash : Block_hash.t;\n block_header : Block_header.shell_header;\n context : t;\n}\n\n(** [rpc_init rpc_context mode] allows to instantiate an [rpc_context]\n using the [Alpha_context] representation from a raw context\n representation (the one the shell knows).\n\n If [mode = `Head_level], the [Alpha_context] uses the same level\n as the head of the chain (given by [rpc_context.block_header]).\n\n If [mode= `Successor_level], the [Alpha_context] uses the\n successor level of the head.\n\n This function aims to be used by RPCs, in particular by RPCs which\n simulate an operation to determine the fees/gas of an\n operation. Using the [`Head_level] can be dangerous if some storage\n paths depend on the level. Using the successor level allows to\n ensure that the simulation is done on a fresh level. *)\nval rpc_init :\n Updater.rpc_context ->\n [`Head_level | `Successor_level] ->\n rpc_context Error_monad.tzresult Lwt.t\n\nval register0 :\n chunked:bool ->\n ( [< RPC_service.meth],\n Updater.rpc_context,\n Updater.rpc_context,\n 'a,\n 'b,\n 'c )\n RPC_service.t ->\n (t -> 'a -> 'b -> 'c Error_monad.tzresult Lwt.t) ->\n unit\n\nval register0_noctxt :\n chunked:bool ->\n ([< RPC_service.meth], Updater.rpc_context, 'a, 'b, 'c, 'd) RPC_service.t ->\n ('b -> 'c -> 'd Error_monad.tzresult Lwt.t) ->\n unit\n\nval register1 :\n chunked:bool ->\n ( [< RPC_service.meth],\n Updater.rpc_context,\n Updater.rpc_context * 'a,\n 'b,\n 'c,\n 'd )\n RPC_service.t ->\n (t -> 'a -> 'b -> 'c -> 'd Error_monad.tzresult Lwt.t) ->\n unit\n\nval register2 :\n chunked:bool ->\n ( [< RPC_service.meth],\n Updater.rpc_context,\n (Updater.rpc_context * 'a) * 'b,\n 'c,\n 'd,\n 'e )\n RPC_service.t ->\n (t -> 'a -> 'b -> 'c -> 'd -> 'e Error_monad.tzresult Lwt.t) ->\n unit\n\nval opt_register0 :\n chunked:bool ->\n ( [< RPC_service.meth],\n Updater.rpc_context,\n Updater.rpc_context,\n 'a,\n 'b,\n 'c )\n RPC_service.t ->\n (t -> 'a -> 'b -> 'c option Error_monad.tzresult Lwt.t) ->\n unit\n\nval opt_register1 :\n chunked:bool ->\n ( [< RPC_service.meth],\n Updater.rpc_context,\n Updater.rpc_context * 'a,\n 'b,\n 'c,\n 'd )\n RPC_service.t ->\n (t -> 'a -> 'b -> 'c -> 'd option Error_monad.tzresult Lwt.t) ->\n unit\n\nval opt_register2 :\n chunked:bool ->\n ( [< RPC_service.meth],\n Updater.rpc_context,\n (Updater.rpc_context * 'a) * 'b,\n 'c,\n 'd,\n 'e )\n RPC_service.t ->\n (t -> 'a -> 'b -> 'c -> 'd -> 'e option Error_monad.tzresult Lwt.t) ->\n unit\n\nval get_rpc_services : unit -> Updater.rpc_context RPC_directory.directory\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\ntype rpc_context = {\n block_hash : Block_hash.t;\n block_header : Block_header.shell_header;\n context : Alpha_context.t;\n}\n\nlet rpc_init ({block_hash; block_header; context} : Updater.rpc_context) mode =\n let timestamp = block_header.timestamp in\n let level =\n match mode with\n | `Head_level -> block_header.level\n | `Successor_level -> Int32.succ block_header.level\n in\n Alpha_context.prepare\n ~level\n ~predecessor_timestamp:timestamp\n ~timestamp\n context\n >|=? fun (context, _, _) -> {block_hash; block_header; context}\n\nlet rpc_services =\n ref (RPC_directory.empty : Updater.rpc_context RPC_directory.t)\n\nlet register0_fullctxt ~chunked s f =\n rpc_services :=\n RPC_directory.register ~chunked !rpc_services s (fun ctxt q i ->\n rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt q i)\n\nlet register0 ~chunked s f =\n register0_fullctxt ~chunked s (fun {context; _} -> f context)\n\nlet register0_noctxt ~chunked s f =\n rpc_services :=\n RPC_directory.register ~chunked !rpc_services s (fun _ q i -> f q i)\n\nlet register1_fullctxt ~chunked s f =\n rpc_services :=\n RPC_directory.register ~chunked !rpc_services s (fun (ctxt, arg) q i ->\n rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg q i)\n\nlet register1 ~chunked s f =\n register1_fullctxt ~chunked s (fun {context; _} x -> f context x)\n\nlet register2_fullctxt ~chunked s f =\n rpc_services :=\n RPC_directory.register\n ~chunked\n !rpc_services\n s\n (fun ((ctxt, arg1), arg2) q i ->\n rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i)\n\nlet register2 ~chunked s f =\n register2_fullctxt ~chunked s (fun {context; _} a1 a2 q i ->\n f context a1 a2 q i)\n\nlet opt_register0_fullctxt ~chunked s f =\n rpc_services :=\n RPC_directory.opt_register ~chunked !rpc_services s (fun ctxt q i ->\n rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt q i)\n\nlet opt_register0 ~chunked s f =\n opt_register0_fullctxt ~chunked s (fun {context; _} -> f context)\n\nlet opt_register1_fullctxt ~chunked s f =\n rpc_services :=\n RPC_directory.opt_register ~chunked !rpc_services s (fun (ctxt, arg) q i ->\n rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg q i)\n\nlet opt_register1 ~chunked s f =\n opt_register1_fullctxt ~chunked s (fun {context; _} x -> f context x)\n\nlet opt_register2_fullctxt ~chunked s f =\n rpc_services :=\n RPC_directory.opt_register\n ~chunked\n !rpc_services\n s\n (fun ((ctxt, arg1), arg2) q i ->\n rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i)\n\nlet opt_register2 ~chunked s f =\n opt_register2_fullctxt ~chunked s (fun {context; _} a1 a2 q i ->\n f context a1 a2 q i)\n\nlet get_rpc_services () =\n let p =\n RPC_directory.map\n (fun c ->\n rpc_init c `Head_level >|= function\n | Error t ->\n raise (Failure (Format.asprintf \"%a\" Error_monad.pp_trace t))\n | Ok c -> c.context)\n (Storage_description.build_directory Alpha_context.description)\n in\n RPC_directory.register_dynamic_directory\n !rpc_services\n RPC_path.(open_root / \"context\" / \"raw\" / \"json\")\n (fun _ -> Lwt.return p)\n" ;
} ;
{ name = "Constants_services" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\nval errors :\n 'a #RPC_context.simple -> 'a -> Data_encoding.json_schema shell_tzresult Lwt.t\n\n(** Returns all the constants of the protocol *)\nval all : 'a #RPC_context.simple -> 'a -> Constants.t shell_tzresult Lwt.t\n\n(** Returns the parametric constants of the protocol *)\nval parametric :\n 'a #RPC_context.simple -> 'a -> Constants.Parametric.t shell_tzresult Lwt.t\n\nval register : unit -> unit\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\nlet custom_root =\n (RPC_path.(open_root / \"context\" / \"constants\")\n : RPC_context.t RPC_path.context)\n\nmodule S = struct\n open Data_encoding\n\n let errors =\n RPC_service.get_service\n ~description:\"Schema for all the RPC errors from this protocol version\"\n ~query:RPC_query.empty\n ~output:json_schema\n RPC_path.(custom_root / \"errors\")\n\n let all =\n RPC_service.get_service\n ~description:\"All constants\"\n ~query:RPC_query.empty\n ~output:Alpha_context.Constants.encoding\n custom_root\n\n let parametric =\n RPC_service.get_service\n ~description:\"Parametric constants\"\n ~query:RPC_query.empty\n ~output:Alpha_context.Constants.Parametric.encoding\n RPC_path.(custom_root / \"parametric\")\nend\n\nlet register () =\n let open Services_registration in\n register0_noctxt ~chunked:true S.errors (fun () () ->\n return Data_encoding.Json.(schema error_encoding)) ;\n register0 ~chunked:false S.all (fun ctxt () () ->\n return @@ Constants.all ctxt) ;\n register0 ~chunked:false S.parametric (fun ctxt () () ->\n return @@ Constants.parametric ctxt)\n\nlet errors ctxt block = RPC_context.make_call0 S.errors ctxt block () ()\n\nlet all ctxt block = RPC_context.make_call0 S.all ctxt block () ()\n\nlet parametric ctxt block = RPC_context.make_call0 S.parametric ctxt block () ()\n" ;
} ;
{ name = "Sapling_services" ;
interface = None ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2019-2020 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\nlet custom_root =\n (RPC_path.(open_root / \"context\" / \"sapling\")\n : RPC_context.t RPC_path.context)\n\ntype diff_query = {\n offset_commitment : Int64.t option;\n offset_nullifier : Int64.t option;\n}\n\nmodule S = struct\n module Args = struct\n type ('query_type, 'output_type) t = {\n name : string;\n description : string;\n query : 'query_type RPC_query.t;\n output : 'output_type Data_encoding.t;\n f : context -> Sapling.Id.t -> 'query_type -> 'output_type tzresult Lwt.t;\n }\n\n let get_diff_query : diff_query RPC_query.t =\n let open RPC_query in\n query (fun offset_commitment offset_nullifier ->\n {offset_commitment; offset_nullifier})\n |+ opt_field\n ~descr:\n \"Commitments and ciphertexts are returned from the specified \\\n offset up to the most recent.\"\n \"offset_commitment\"\n RPC_arg.uint63\n (fun {offset_commitment; _} -> offset_commitment)\n |+ opt_field\n ~descr:\n \"Nullifiers are returned from the specified offset up to the most \\\n recent.\"\n \"offset_nullifier\"\n RPC_arg.uint63\n (fun {offset_nullifier; _} -> offset_nullifier)\n |> seal\n\n let encoding =\n let open Data_encoding in\n merge_objs (obj1 (req \"root\" Sapling.root_encoding)) Sapling.diff_encoding\n\n let get_diff =\n {\n name = \"get_diff\";\n description =\n \"Returns the root and a diff of a state starting from an optional \\\n offset which is zero by default.\";\n query = get_diff_query;\n output = encoding;\n f =\n (fun ctxt id {offset_commitment; offset_nullifier} ->\n Sapling.get_diff ctxt id ?offset_commitment ?offset_nullifier ());\n }\n end\n\n let make_service Args.{name; description; query; output; f} =\n let path = RPC_path.(custom_root /: Sapling.rpc_arg / name) in\n let service = RPC_service.get_service ~description ~query ~output path in\n (service, fun ctxt id q () -> f ctxt id q)\n\n let get_diff = make_service Args.get_diff\nend\n\nlet register () =\n let reg ~chunked (service, f) =\n Services_registration.register1 ~chunked service f\n in\n reg ~chunked:false S.get_diff\n\nlet mk_call1 (service, _f) ctxt block id q =\n RPC_context.make_call1 service ctxt block id q ()\n\nlet get_diff ctxt block id ?offset_commitment ?offset_nullifier () =\n mk_call1 S.get_diff ctxt block id {offset_commitment; offset_nullifier}\n" ;
} ;
{ name = "Contract_services" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2019-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module defines RPC services to access the information associated to\n contracts (balance, delegate, script, etc.).\n*)\n\nopen Alpha_context\n\nval list : 'a #RPC_context.simple -> 'a -> Contract.t list shell_tzresult Lwt.t\n\ntype info = {\n balance : Tez.t;\n delegate : public_key_hash option;\n counter : Manager_counter.t option;\n script : Script.t option;\n}\n\nval info_encoding : info Data_encoding.t\n\nval info :\n 'a #RPC_context.simple ->\n 'a ->\n Contract.t ->\n normalize_types:bool ->\n info shell_tzresult Lwt.t\n\nval balance :\n 'a #RPC_context.simple -> 'a -> Contract.t -> Tez.t shell_tzresult Lwt.t\n\nval frozen_bonds :\n 'a #RPC_context.simple -> 'a -> Contract.t -> Tez.t shell_tzresult Lwt.t\n\nval balance_and_frozen_bonds :\n 'a #RPC_context.simple -> 'a -> Contract.t -> Tez.t shell_tzresult Lwt.t\n\nval manager_key :\n 'a #RPC_context.simple ->\n 'a ->\n public_key_hash ->\n public_key option shell_tzresult Lwt.t\n\nval delegate :\n 'a #RPC_context.simple ->\n 'a ->\n Contract.t ->\n public_key_hash shell_tzresult Lwt.t\n\nval delegate_opt :\n 'a #RPC_context.simple ->\n 'a ->\n Contract.t ->\n public_key_hash option shell_tzresult Lwt.t\n\nval counter :\n 'a #RPC_context.simple ->\n 'a ->\n public_key_hash ->\n Manager_counter.t shell_tzresult Lwt.t\n\nval script :\n 'a #RPC_context.simple ->\n 'a ->\n Contract_hash.t ->\n Script.t shell_tzresult Lwt.t\n\nval script_opt :\n 'a #RPC_context.simple ->\n 'a ->\n Contract_hash.t ->\n Script.t option shell_tzresult Lwt.t\n\nval storage :\n 'a #RPC_context.simple ->\n 'a ->\n Contract_hash.t ->\n Script.expr shell_tzresult Lwt.t\n\nval entrypoint_type :\n 'a #RPC_context.simple ->\n 'a ->\n Contract_hash.t ->\n Entrypoint.t ->\n normalize_types:bool ->\n Script.expr shell_tzresult Lwt.t\n\nval list_entrypoints :\n 'a #RPC_context.simple ->\n 'a ->\n Contract_hash.t ->\n normalize_types:bool ->\n (Michelson_v1_primitives.prim list list * (string * Script.expr) list)\n shell_tzresult\n Lwt.t\n\nval storage_opt :\n 'a #RPC_context.simple ->\n 'a ->\n Contract_hash.t ->\n Script.expr option shell_tzresult Lwt.t\n\nval big_map_get :\n 'a #RPC_context.simple ->\n 'a ->\n Big_map.Id.t ->\n Script_expr_hash.t ->\n Script.expr shell_tzresult Lwt.t\n\nval contract_big_map_get_opt :\n 'a #RPC_context.simple ->\n 'a ->\n Contract_hash.t ->\n Script.expr * Script.expr ->\n Script.expr option shell_tzresult Lwt.t\n\nval single_sapling_get_diff :\n 'a #RPC_context.simple ->\n 'a ->\n Contract_hash.t ->\n ?offset_commitment:int64 ->\n ?offset_nullifier:int64 ->\n unit ->\n (Sapling.root * Sapling.diff) shell_tzresult Lwt.t\n\nval register : unit -> unit\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2019-2020 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\nlet custom_root =\n (RPC_path.(open_root / \"context\" / \"contracts\")\n : RPC_context.t RPC_path.context)\n\nlet big_map_root =\n (RPC_path.(open_root / \"context\" / \"big_maps\")\n : RPC_context.t RPC_path.context)\n\ntype info = {\n balance : Tez.t;\n delegate : public_key_hash option;\n counter : Manager_counter.t option;\n script : Script.t option;\n}\n\nlet info_encoding =\n let open Data_encoding in\n conv\n (fun {balance; delegate; script; counter} ->\n (balance, delegate, script, counter))\n (fun (balance, delegate, script, counter) ->\n {balance; delegate; script; counter})\n @@ obj4\n (req \"balance\" Tez.encoding)\n (opt \"delegate\" Signature.Public_key_hash.encoding)\n (opt \"script\" Script.encoding)\n (opt \"counter\" Manager_counter.encoding_for_RPCs)\n\nlet legacy = Script_ir_translator_config.make ~legacy:true ()\n\nmodule S = struct\n open Data_encoding\n\n let balance =\n RPC_service.get_service\n ~description:\n \"Access the spendable balance of a contract, excluding frozen bonds.\"\n ~query:RPC_query.empty\n ~output:Tez.encoding\n RPC_path.(custom_root /: Contract.rpc_arg / \"balance\")\n\n let frozen_bonds =\n RPC_service.get_service\n ~description:\"Access the frozen bonds of a contract.\"\n ~query:RPC_query.empty\n ~output:Tez.encoding\n RPC_path.(custom_root /: Contract.rpc_arg / \"frozen_bonds\")\n\n let balance_and_frozen_bonds =\n RPC_service.get_service\n ~description:\n \"Access the sum of the spendable balance and frozen bonds of a \\\n contract. This sum is part of the contract's stake, and it is exactly \\\n the contract's stake if the contract is not a delegate.\"\n ~query:RPC_query.empty\n ~output:Tez.encoding\n RPC_path.(custom_root /: Contract.rpc_arg / \"balance_and_frozen_bonds\")\n\n let manager_key =\n RPC_service.get_service\n ~description:\"Access the manager of an implicit contract.\"\n ~query:RPC_query.empty\n ~output:(option Signature.Public_key.encoding)\n RPC_path.(custom_root /: Contract.rpc_arg / \"manager_key\")\n\n let delegate =\n RPC_service.get_service\n ~description:\"Access the delegate of a contract, if any.\"\n ~query:RPC_query.empty\n ~output:Signature.Public_key_hash.encoding\n RPC_path.(custom_root /: Contract.rpc_arg / \"delegate\")\n\n let counter =\n RPC_service.get_service\n ~description:\"Access the counter of a contract, if any.\"\n ~query:RPC_query.empty\n ~output:Manager_counter.encoding_for_RPCs\n RPC_path.(custom_root /: Contract.rpc_arg / \"counter\")\n\n let script =\n RPC_service.get_service\n ~description:\"Access the code and data of the contract.\"\n ~query:RPC_query.empty\n ~output:Script.encoding\n RPC_path.(custom_root /: Contract.rpc_arg / \"script\")\n\n let storage =\n RPC_service.get_service\n ~description:\"Access the data of the contract.\"\n ~query:RPC_query.empty\n ~output:Script.expr_encoding\n RPC_path.(custom_root /: Contract.rpc_arg / \"storage\")\n\n type normalize_types_query = {normalize_types : bool}\n\n let normalize_types_query : normalize_types_query RPC_query.t =\n let open RPC_query in\n query (fun normalize_types -> {normalize_types})\n |+ flag\n ~descr:\n \"Whether types should be normalized (annotations removed, combs \\\n flattened) or kept as they appeared in the original script.\"\n \"normalize_types\"\n (fun t -> t.normalize_types)\n |> seal\n\n let entrypoint_type =\n RPC_service.get_service\n ~description:\"Return the type of the given entrypoint of the contract\"\n ~query:normalize_types_query\n ~output:Script.expr_encoding\n RPC_path.(\n custom_root /: Contract.rpc_arg / \"entrypoints\" /: Entrypoint.rpc_arg)\n\n let list_entrypoints =\n RPC_service.get_service\n ~description:\"Return the list of entrypoints of the contract\"\n ~query:normalize_types_query\n ~output:\n (obj2\n (dft\n \"unreachable\"\n (Data_encoding.list\n (obj1\n (req\n \"path\"\n (Data_encoding.list\n Michelson_v1_primitives.prim_encoding))))\n [])\n (req \"entrypoints\" (assoc Script.expr_encoding)))\n RPC_path.(custom_root /: Contract.rpc_arg / \"entrypoints\")\n\n let contract_big_map_get_opt =\n RPC_service.post_service\n ~description:\n \"Access the value associated with a key in a big map of the contract \\\n (deprecated).\"\n ~query:RPC_query.empty\n ~input:\n (obj2\n (req \"key\" Script.expr_encoding)\n (req \"type\" Script.expr_encoding))\n ~output:(option Script.expr_encoding)\n RPC_path.(custom_root /: Contract.rpc_arg / \"big_map_get\")\n\n let big_map_get =\n RPC_service.get_service\n ~description:\"Access the value associated with a key in a big map.\"\n ~query:RPC_query.empty\n ~output:Script.expr_encoding\n RPC_path.(big_map_root /: Big_map.Id.rpc_arg /: Script_expr_hash.rpc_arg)\n\n type big_map_get_all_query = {offset : int option; length : int option}\n\n let rpc_arg_uint : int RPC_arg.t =\n let int_of_string s =\n int_of_string_opt s\n |> Option.to_result\n ~none:(Format.sprintf \"Cannot parse integer value %s\" s)\n >>? fun i ->\n if Compare.Int.(i < 0) then\n Error (Format.sprintf \"Negative integer: %d\" i)\n else Ok i\n in\n RPC_arg.make\n ~name:\"uint\"\n ~descr:\"A non-negative integer (greater than or equal to 0).\"\n ~destruct:int_of_string\n ~construct:string_of_int\n ()\n\n let big_map_get_all_query : big_map_get_all_query RPC_query.t =\n let open RPC_query in\n query (fun offset length -> {offset; length})\n |+ opt_field\n ~descr:\n \"Skip the first [offset] values. Useful in combination with \\\n [length] for pagination.\"\n \"offset\"\n rpc_arg_uint\n (fun t -> t.offset)\n |+ opt_field\n ~descr:\n \"Only retrieve [length] values. Useful in combination with [offset] \\\n for pagination.\"\n \"length\"\n rpc_arg_uint\n (fun t -> t.length)\n |> seal\n\n let big_map_get_all =\n RPC_service.get_service\n ~description:\n \"Get the (optionally paginated) list of values in a big map. Order of \\\n values is unspecified, but is guaranteed to be consistent.\"\n ~query:big_map_get_all_query\n ~output:(list Script.expr_encoding)\n RPC_path.(big_map_root /: Big_map.Id.rpc_arg)\n\n let info =\n RPC_service.get_service\n ~description:\"Access the complete status of a contract.\"\n ~query:normalize_types_query\n ~output:info_encoding\n RPC_path.(custom_root /: Contract.rpc_arg)\n\n let list =\n RPC_service.get_service\n ~description:\n \"All existing contracts (excluding empty implicit contracts).\"\n ~query:RPC_query.empty\n ~output:(list Contract.encoding)\n custom_root\n\n module Sapling = struct\n (*\n Sapling: these RPCs are like Sapling RPCs (sapling_services.ml)\n specialized for contracts containing a single sapling state.\n *)\n\n let single_sapling_get_id ctxt contract_id =\n Contract.get_script ctxt contract_id >>=? fun (ctxt, script) ->\n match script with\n | None -> return (None, ctxt)\n | Some script ->\n let ctxt = Gas.set_unlimited ctxt in\n Script_ir_translator.parse_script\n ctxt\n ~elab_conf:legacy\n ~allow_forged_in_storage:true\n script\n >|= fun tzresult ->\n tzresult >>? fun (Ex_script (Script script), ctxt) ->\n Script_ir_translator.get_single_sapling_state\n ctxt\n script.storage_type\n script.storage\n\n let make_service\n Sapling_services.S.Args.{name; description; query; output; f} =\n let name = \"single_sapling_\" ^ name in\n let path = RPC_path.(custom_root /: Contract.rpc_arg / name) in\n let service = RPC_service.get_service ~description ~query ~output path in\n ( service,\n fun ctxt contract_id q () ->\n match (contract_id : Contract.t) with\n | Implicit _ -> return_none\n | Originated contract_id ->\n single_sapling_get_id ctxt contract_id\n >>=? fun (sapling_id, ctxt) ->\n Option.map_es (fun sapling_id -> f ctxt sapling_id q) sapling_id\n )\n\n let get_diff = make_service Sapling_services.S.Args.get_diff\n\n let register () =\n let reg chunked (service, f) =\n Services_registration.opt_register1 ~chunked service f\n in\n reg false get_diff\n\n let mk_call1 (service, _f) ctxt block id q =\n RPC_context.make_call1 service ctxt block id q ()\n end\nend\n\nlet register () =\n let open Services_registration in\n register0 ~chunked:true S.list (fun ctxt () () -> Contract.list ctxt >|= ok) ;\n let register_field_gen ~filter_contract ~wrap_result ~chunked s f =\n opt_register1 ~chunked s (fun ctxt contract () () ->\n filter_contract contract @@ fun filtered_contract ->\n Contract.exists ctxt contract >>= function\n | true -> f ctxt filtered_contract |> wrap_result\n | false -> return_none)\n in\n let register_field_with_query_gen ~filter_contract ~wrap_result ~chunked s f =\n opt_register1 ~chunked s (fun ctxt contract query () ->\n filter_contract contract @@ fun filtered_contract ->\n Contract.exists ctxt contract >>= function\n | true -> f ctxt filtered_contract query |> wrap_result\n | false -> return_none)\n in\n let register_field s =\n register_field_gen\n ~filter_contract:(fun c k -> k c)\n ~wrap_result:(fun res -> res >|=? Option.some)\n s\n in\n let register_field_with_query s =\n register_field_with_query_gen\n ~filter_contract:(fun c k -> k c)\n ~wrap_result:(fun res -> res >|=? Option.some)\n s\n in\n let register_opt_field s =\n register_field_gen\n ~filter_contract:(fun c k -> k c)\n ~wrap_result:(fun res -> res)\n s\n in\n let register_originated_opt_field s =\n register_field_gen\n ~filter_contract:(fun c k ->\n match (c : Contract.t) with\n | Implicit _ -> return_none\n | Originated c -> k c)\n ~wrap_result:(fun res -> res)\n s\n in\n let do_big_map_get ctxt id key =\n let open Script_ir_translator in\n let ctxt = Gas.set_unlimited ctxt in\n Big_map.exists ctxt id >>=? fun (ctxt, types) ->\n match types with\n | None -> return_none\n | Some (_, value_type) -> (\n parse_big_map_value_ty ctxt ~legacy:true (Micheline.root value_type)\n >>?= fun (Ex_ty value_type, ctxt) ->\n Big_map.get_opt ctxt id key >>=? fun (_ctxt, value) ->\n match value with\n | None -> return_none\n | Some value ->\n parse_data\n ctxt\n ~elab_conf:legacy\n ~allow_forged:true\n value_type\n (Micheline.root value)\n >>=? fun (value, ctxt) ->\n unparse_data ctxt Readable value_type value\n >|=? fun (value, _ctxt) -> Some value)\n in\n let do_big_map_get_all ?offset ?length ctxt id =\n let open Script_ir_translator in\n let ctxt = Gas.set_unlimited ctxt in\n Big_map.exists ctxt id >>=? fun (ctxt, types) ->\n match types with\n | None -> raise Not_found\n | Some (_, value_type) ->\n parse_big_map_value_ty ctxt ~legacy:true (Micheline.root value_type)\n >>?= fun (Ex_ty value_type, ctxt) ->\n Big_map.list_key_values ?offset ?length ctxt id\n >>=? fun (ctxt, key_values) ->\n List.fold_left_s\n (fun acc (_key_hash, value) ->\n acc >>?= fun (ctxt, rev_values) ->\n parse_data\n ctxt\n ~elab_conf:legacy\n ~allow_forged:true\n value_type\n (Micheline.root value)\n >>=? fun (value, ctxt) ->\n unparse_data ctxt Readable value_type value\n >|=? fun (value, ctxt) -> (ctxt, value :: rev_values))\n (Ok (ctxt, []))\n key_values\n >|=? fun (_ctxt, rev_values) -> List.rev rev_values\n in\n register_field ~chunked:false S.balance Contract.get_balance ;\n register_field ~chunked:false S.frozen_bonds Contract.get_frozen_bonds ;\n register_field\n ~chunked:false\n S.balance_and_frozen_bonds\n Contract.get_balance_and_frozen_bonds ;\n opt_register1 ~chunked:false S.manager_key (fun ctxt contract () () ->\n match contract with\n | Originated _ -> return_none\n | Implicit mgr -> (\n Contract.is_manager_key_revealed ctxt mgr >>=? function\n | false -> return_some None\n | true ->\n Contract.get_manager_key ctxt mgr >|=? fun key -> Some (Some key))) ;\n register_opt_field ~chunked:false S.delegate Contract.Delegate.find ;\n opt_register1 ~chunked:false S.counter (fun ctxt contract () () ->\n match contract with\n | Originated _ -> return_none\n | Implicit mgr ->\n Contract.get_counter ctxt mgr >|=? fun counter -> Some counter) ;\n register_originated_opt_field ~chunked:true S.script (fun c v ->\n Contract.get_script c v >|=? fun (_, v) -> v) ;\n register_originated_opt_field ~chunked:true S.storage (fun ctxt contract ->\n Contract.get_script ctxt contract >>=? fun (ctxt, script) ->\n match script with\n | None -> return_none\n | Some script ->\n let ctxt = Gas.set_unlimited ctxt in\n let open Script_ir_translator in\n parse_script\n ctxt\n ~elab_conf:legacy\n ~allow_forged_in_storage:true\n script\n >>=? fun (Ex_script (Script {storage; storage_type; _}), ctxt) ->\n unparse_data ctxt Readable storage_type storage\n >|=? fun (storage, _ctxt) -> Some storage) ;\n opt_register2\n ~chunked:true\n S.entrypoint_type\n (fun ctxt v entrypoint {normalize_types} () ->\n match (v : Contract.t) with\n | Implicit _ -> return_none\n | Originated v -> (\n Contract.get_script_code ctxt v >>=? fun (_, expr) ->\n match expr with\n | None -> return_none\n | Some expr ->\n let ctxt = Gas.set_unlimited ctxt in\n let legacy = true in\n let open Script_ir_translator in\n Script.force_decode_in_context\n ~consume_deserialization_gas:When_needed\n ctxt\n expr\n >>?= fun (expr, _) ->\n parse_toplevel ctxt ~legacy expr >>=? fun ({arg_type; _}, ctxt) ->\n Lwt.return\n ( parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type\n >>? fun ( Ex_parameter_ty_and_entrypoints {arg_type; entrypoints},\n _ ) ->\n Gas_monad.run ctxt\n @@ Script_ir_translator.find_entrypoint\n ~error_details:(Informative ())\n arg_type\n entrypoints\n entrypoint\n >>? fun (r, ctxt) ->\n r |> function\n | Ok (Ex_ty_cstr {ty; original_type_expr; _}) ->\n if normalize_types then\n Script_ir_unparser.unparse_ty ~loc:() ctxt ty\n >|? fun (ty_node, _ctxt) ->\n Some (Micheline.strip_locations ty_node)\n else\n ok (Some (Micheline.strip_locations original_type_expr))\n | Error _ -> Result.return_none ))) ;\n opt_register1\n ~chunked:true\n S.list_entrypoints\n (fun ctxt v {normalize_types} () ->\n match (v : Contract.t) with\n | Implicit _ -> return_none\n | Originated v -> (\n Contract.get_script_code ctxt v >>=? fun (_, expr) ->\n match expr with\n | None -> return_none\n | Some expr ->\n let ctxt = Gas.set_unlimited ctxt in\n let legacy = true in\n let open Script_ir_translator in\n Script.force_decode_in_context\n ~consume_deserialization_gas:When_needed\n ctxt\n expr\n >>?= fun (expr, _) ->\n parse_toplevel ctxt ~legacy expr >>=? fun ({arg_type; _}, ctxt) ->\n Lwt.return\n ( parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type\n >>? fun ( Ex_parameter_ty_and_entrypoints {arg_type; entrypoints},\n _ ) ->\n let unreachable_entrypoint, map =\n Script_ir_translator.list_entrypoints_uncarbonated\n arg_type\n entrypoints\n in\n Entrypoint.Map.fold_e\n (fun entry\n (Script_typed_ir.Ex_ty ty, original_type_expr)\n (acc, ctxt) ->\n (if normalize_types then\n Script_ir_unparser.unparse_ty ~loc:() ctxt ty\n >|? fun (ty_node, ctxt) ->\n (Micheline.strip_locations ty_node, ctxt)\n else\n ok (Micheline.strip_locations original_type_expr, ctxt))\n >|? fun (ty_expr, ctxt) ->\n ((Entrypoint.to_string entry, ty_expr) :: acc, ctxt))\n map\n ([], ctxt)\n >|? fun (entrypoint_types, _ctxt) ->\n Some (unreachable_entrypoint, entrypoint_types) ))) ;\n opt_register1\n ~chunked:true\n S.contract_big_map_get_opt\n (fun ctxt contract () (key, key_type) ->\n match (contract : Contract.t) with\n | Implicit _ -> return_none\n | Originated contract -> (\n Contract.get_script ctxt contract >>=? fun (ctxt, script) ->\n let key_type_node = Micheline.root key_type in\n Script_ir_translator.parse_comparable_ty ctxt key_type_node\n >>?= fun (Ex_comparable_ty key_type, ctxt) ->\n Script_ir_translator.parse_comparable_data\n ctxt\n key_type\n (Micheline.root key)\n >>=? fun (key, ctxt) ->\n Script_ir_translator.hash_comparable_data ctxt key_type key\n >>=? fun (key, ctxt) ->\n match script with\n | None -> return_none\n | Some script -> (\n let ctxt = Gas.set_unlimited ctxt in\n let open Script_ir_translator in\n parse_script\n ctxt\n ~elab_conf:legacy\n ~allow_forged_in_storage:true\n script\n >>=? fun (Ex_script (Script script), ctxt) ->\n Script_ir_translator.collect_lazy_storage\n ctxt\n script.storage_type\n script.storage\n >>?= fun (ids, _ctxt) ->\n match Script_ir_translator.list_of_big_map_ids ids with\n | [] | _ :: _ :: _ -> return_some None\n | [id] -> do_big_map_get ctxt id key >|=? Option.some))) ;\n opt_register2 ~chunked:true S.big_map_get (fun ctxt id key () () ->\n do_big_map_get ctxt id key) ;\n register1 ~chunked:true S.big_map_get_all (fun ctxt id {offset; length} () ->\n do_big_map_get_all ?offset ?length ctxt id) ;\n register_field_with_query\n ~chunked:false\n S.info\n (fun ctxt contract {normalize_types} ->\n Contract.get_balance ctxt contract >>=? fun balance ->\n Contract.Delegate.find ctxt contract >>=? fun delegate ->\n match contract with\n | Implicit manager ->\n Contract.get_counter ctxt manager >|=? fun counter ->\n {balance; delegate; script = None; counter = Some counter}\n | Originated contract -> (\n Contract.get_script ctxt contract >>=? fun (ctxt, script) ->\n match script with\n | None -> return {balance; delegate; script = None; counter = None}\n | Some script ->\n let ctxt = Gas.set_unlimited ctxt in\n Script_ir_translator.parse_and_unparse_script_unaccounted\n ctxt\n ~legacy:true\n ~allow_forged_in_storage:true\n Readable\n ~normalize_types\n script\n >|=? fun (script, _ctxt) ->\n {balance; delegate; script = Some script; counter = None})) ;\n S.Sapling.register ()\n\nlet list ctxt block = RPC_context.make_call0 S.list ctxt block () ()\n\nlet info ctxt block contract ~normalize_types =\n RPC_context.make_call1 S.info ctxt block contract {normalize_types} ()\n\nlet balance ctxt block contract =\n RPC_context.make_call1 S.balance ctxt block contract () ()\n\nlet frozen_bonds ctxt block contract =\n RPC_context.make_call1 S.frozen_bonds ctxt block contract () ()\n\nlet balance_and_frozen_bonds ctxt block contract =\n RPC_context.make_call1 S.balance_and_frozen_bonds ctxt block contract () ()\n\nlet manager_key ctxt block mgr =\n RPC_context.make_call1 S.manager_key ctxt block (Contract.Implicit mgr) () ()\n\nlet delegate ctxt block contract =\n RPC_context.make_call1 S.delegate ctxt block contract () ()\n\nlet delegate_opt ctxt block contract =\n RPC_context.make_opt_call1 S.delegate ctxt block contract () ()\n\nlet counter ctxt block mgr =\n RPC_context.make_call1 S.counter ctxt block (Contract.Implicit mgr) () ()\n\nlet script ctxt block contract =\n let contract = Contract.Originated contract in\n RPC_context.make_call1 S.script ctxt block contract () ()\n\nlet script_opt ctxt block contract =\n let contract = Contract.Originated contract in\n RPC_context.make_opt_call1 S.script ctxt block contract () ()\n\nlet storage ctxt block contract =\n let contract = Contract.Originated contract in\n RPC_context.make_call1 S.storage ctxt block contract () ()\n\nlet entrypoint_type ctxt block contract entrypoint ~normalize_types =\n RPC_context.make_call2\n S.entrypoint_type\n ctxt\n block\n (Contract.Originated contract)\n entrypoint\n {normalize_types}\n ()\n\nlet list_entrypoints ctxt block contract ~normalize_types =\n RPC_context.make_call1\n S.list_entrypoints\n ctxt\n block\n (Contract.Originated contract)\n {normalize_types}\n ()\n\nlet storage_opt ctxt block contract =\n let contract = Contract.Originated contract in\n RPC_context.make_opt_call1 S.storage ctxt block contract () ()\n\nlet big_map_get ctxt block id key =\n RPC_context.make_call2 S.big_map_get ctxt block id key () ()\n\nlet contract_big_map_get_opt ctxt block contract key =\n let contract = Contract.Originated contract in\n RPC_context.make_call1 S.contract_big_map_get_opt ctxt block contract () key\n\nlet single_sapling_get_diff ctxt block id ?offset_commitment ?offset_nullifier\n () =\n S.Sapling.(mk_call1 get_diff)\n ctxt\n block\n (Contract.Originated id)\n Sapling_services.{offset_commitment; offset_nullifier}\n" ;
} ;
{ name = "Delegate_services" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module defines RPC services to access the information associated to\n delegates (who they are, their delegators, their different kinds of balances, their activity, etc.).\n*)\n\nopen Alpha_context\n\ntype error += (* `Temporary *) Not_registered of Signature.Public_key_hash.t\n\nval list :\n 'a #RPC_context.simple ->\n 'a ->\n ?active:bool ->\n ?inactive:bool ->\n ?with_minimal_stake:bool ->\n ?without_minimal_stake:bool ->\n unit ->\n Signature.Public_key_hash.t list shell_tzresult Lwt.t\n\ntype info = {\n full_balance : Tez.t; (** Balance + Frozen balance *)\n current_frozen_deposits : Tez.t;\n frozen_deposits : Tez.t;\n staking_balance : Tez.t;\n frozen_deposits_limit : Tez.t option;\n delegated_contracts : Contract.t list;\n delegated_balance : Tez.t;\n deactivated : bool;\n grace_period : Cycle.t;\n voting_info : Vote.delegate_info;\n active_consensus_key : Signature.Public_key_hash.t;\n pending_consensus_keys : (Cycle.t * Signature.Public_key_hash.t) list;\n}\n\nval info_encoding : info Data_encoding.t\n\nval info :\n 'a #RPC_context.simple ->\n 'a ->\n Signature.Public_key_hash.t ->\n info shell_tzresult Lwt.t\n\nval full_balance :\n 'a #RPC_context.simple ->\n 'a ->\n Signature.Public_key_hash.t ->\n Tez.t shell_tzresult Lwt.t\n\nval current_frozen_deposits :\n 'a #RPC_context.simple ->\n 'a ->\n Signature.Public_key_hash.t ->\n Tez.t shell_tzresult Lwt.t\n\nval frozen_deposits :\n 'a #RPC_context.simple ->\n 'a ->\n Signature.Public_key_hash.t ->\n Tez.t shell_tzresult Lwt.t\n\nval staking_balance :\n 'a #RPC_context.simple ->\n 'a ->\n Signature.Public_key_hash.t ->\n Tez.t shell_tzresult Lwt.t\n\nval frozen_deposits_limit :\n 'a #RPC_context.simple ->\n 'a ->\n Signature.Public_key_hash.t ->\n Tez.t option shell_tzresult Lwt.t\n\nval delegated_contracts :\n 'a #RPC_context.simple ->\n 'a ->\n Signature.Public_key_hash.t ->\n Contract.t list shell_tzresult Lwt.t\n\nval delegated_balance :\n 'a #RPC_context.simple ->\n 'a ->\n Signature.Public_key_hash.t ->\n Tez.t shell_tzresult Lwt.t\n\nval deactivated :\n 'a #RPC_context.simple ->\n 'a ->\n Signature.Public_key_hash.t ->\n bool shell_tzresult Lwt.t\n\nval grace_period :\n 'a #RPC_context.simple ->\n 'a ->\n Signature.Public_key_hash.t ->\n Cycle.t shell_tzresult Lwt.t\n\nval voting_power :\n 'a #RPC_context.simple -> 'a -> public_key_hash -> int64 shell_tzresult Lwt.t\n\nval voting_info :\n 'a #RPC_context.simple ->\n 'a ->\n public_key_hash ->\n Vote.delegate_info shell_tzresult Lwt.t\n\nval consensus_key :\n 'a #RPC_context.simple ->\n 'a ->\n Signature.Public_key_hash.t ->\n (Signature.Public_key_hash.t * (Cycle.t * Signature.Public_key_hash.t) list)\n shell_tzresult\n Lwt.t\n\nval participation :\n 'a #RPC_context.simple ->\n 'a ->\n public_key_hash ->\n Delegate.participation_info shell_tzresult Lwt.t\n\nval register : unit -> unit\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2020 Metastate AG <hello@metastate.dev> *)\n(* Copyright (c) 2021 Nomadic Labs, <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\ntype error += Balance_rpc_non_delegate of public_key_hash\n\ntype error += (* `Temporary *) Not_registered of Signature.Public_key_hash.t\n\nlet () =\n register_error_kind\n `Temporary\n ~id:\"delegate.not_registered\"\n ~title:\"Not a registered delegate\"\n ~description:\n \"The provided public key hash is not the address of a registered \\\n delegate.\"\n ~pp:(fun ppf pkh ->\n Format.fprintf\n ppf\n \"The provided public key hash (%a) is not the address of a registered \\\n delegate. If you own this account and want to register it as a \\\n delegate, use a delegation operation to delegate the account to \\\n itself.\"\n Signature.Public_key_hash.pp\n pkh)\n Data_encoding.(obj1 (req \"pkh\" Signature.Public_key_hash.encoding))\n (function Not_registered pkh -> Some pkh | _ -> None)\n (fun pkh -> Not_registered pkh)\n\nlet () =\n register_error_kind\n `Temporary\n ~id:\"delegate_service.balance_rpc_on_non_delegate\"\n ~title:\"Balance request for an unregistered delegate\"\n ~description:\"The account whose balance was requested is not a delegate.\"\n ~pp:(fun ppf pkh ->\n Format.fprintf\n ppf\n \"The implicit account (%a) whose balance was requested is not a \\\n registered delegate. To get the balance of this account you can use \\\n the ../context/contracts/%a/balance RPC.\"\n Signature.Public_key_hash.pp\n pkh\n Signature.Public_key_hash.pp\n pkh)\n Data_encoding.(obj1 (req \"pkh\" Signature.Public_key_hash.encoding))\n (function Balance_rpc_non_delegate pkh -> Some pkh | _ -> None)\n (fun pkh -> Balance_rpc_non_delegate pkh)\n\ntype info = {\n full_balance : Tez.t;\n current_frozen_deposits : Tez.t;\n frozen_deposits : Tez.t;\n staking_balance : Tez.t;\n frozen_deposits_limit : Tez.t option;\n delegated_contracts : Contract.t list;\n delegated_balance : Tez.t;\n deactivated : bool;\n grace_period : Cycle.t;\n voting_info : Vote.delegate_info;\n active_consensus_key : Signature.Public_key_hash.t;\n pending_consensus_keys : (Cycle.t * Signature.Public_key_hash.t) list;\n}\n\nlet info_encoding =\n let open Data_encoding in\n conv\n (fun {\n full_balance;\n current_frozen_deposits;\n frozen_deposits;\n staking_balance;\n frozen_deposits_limit;\n delegated_contracts;\n delegated_balance;\n deactivated;\n grace_period;\n voting_info;\n active_consensus_key;\n pending_consensus_keys;\n } ->\n ( ( full_balance,\n current_frozen_deposits,\n frozen_deposits,\n staking_balance,\n frozen_deposits_limit,\n delegated_contracts,\n delegated_balance,\n deactivated,\n grace_period ),\n (voting_info, (active_consensus_key, pending_consensus_keys)) ))\n (fun ( ( full_balance,\n current_frozen_deposits,\n frozen_deposits,\n staking_balance,\n frozen_deposits_limit,\n delegated_contracts,\n delegated_balance,\n deactivated,\n grace_period ),\n (voting_info, (active_consensus_key, pending_consensus_keys)) ) ->\n {\n full_balance;\n current_frozen_deposits;\n frozen_deposits;\n staking_balance;\n frozen_deposits_limit;\n delegated_contracts;\n delegated_balance;\n deactivated;\n grace_period;\n voting_info;\n active_consensus_key;\n pending_consensus_keys;\n })\n (merge_objs\n (obj9\n (req \"full_balance\" Tez.encoding)\n (req \"current_frozen_deposits\" Tez.encoding)\n (req \"frozen_deposits\" Tez.encoding)\n (req \"staking_balance\" Tez.encoding)\n (opt \"frozen_deposits_limit\" Tez.encoding)\n (req \"delegated_contracts\" (list Contract.encoding))\n (req \"delegated_balance\" Tez.encoding)\n (req \"deactivated\" bool)\n (req \"grace_period\" Cycle.encoding))\n (merge_objs\n Vote.delegate_info_encoding\n (obj2\n (req \"active_consensus_key\" Signature.Public_key_hash.encoding)\n (dft\n \"pending_consensus_keys\"\n (list\n (obj2\n (req \"cycle\" Cycle.encoding)\n (req \"pkh\" Signature.Public_key_hash.encoding)))\n []))))\n\nlet participation_info_encoding =\n let open Data_encoding in\n conv\n (fun {\n Delegate.expected_cycle_activity;\n minimal_cycle_activity;\n missed_slots;\n missed_levels;\n remaining_allowed_missed_slots;\n expected_endorsing_rewards;\n } ->\n ( expected_cycle_activity,\n minimal_cycle_activity,\n missed_slots,\n missed_levels,\n remaining_allowed_missed_slots,\n expected_endorsing_rewards ))\n (fun ( expected_cycle_activity,\n minimal_cycle_activity,\n missed_slots,\n missed_levels,\n remaining_allowed_missed_slots,\n expected_endorsing_rewards ) ->\n {\n expected_cycle_activity;\n minimal_cycle_activity;\n missed_slots;\n missed_levels;\n remaining_allowed_missed_slots;\n expected_endorsing_rewards;\n })\n (obj6\n (req \"expected_cycle_activity\" int31)\n (req \"minimal_cycle_activity\" int31)\n (req \"missed_slots\" int31)\n (req \"missed_levels\" int31)\n (req \"remaining_allowed_missed_slots\" int31)\n (req \"expected_endorsing_rewards\" Tez.encoding))\n\nmodule S = struct\n let raw_path = RPC_path.(open_root / \"context\" / \"delegates\")\n\n open Data_encoding\n\n type list_query = {\n active : bool;\n inactive : bool;\n with_minimal_stake : bool;\n without_minimal_stake : bool;\n }\n\n let list_query : list_query RPC_query.t =\n let open RPC_query in\n query (fun active inactive with_minimal_stake without_minimal_stake ->\n {active; inactive; with_minimal_stake; without_minimal_stake})\n |+ flag \"active\" (fun t -> t.active)\n |+ flag \"inactive\" (fun t -> t.inactive)\n |+ flag \"with_minimal_stake\" (fun t -> t.with_minimal_stake)\n |+ flag \"without_minimal_stake\" (fun t -> t.without_minimal_stake)\n |> seal\n\n let list_delegate =\n RPC_service.get_service\n ~description:\n \"Lists all registered delegates by default. The arguments `active`, \\\n `inactive`, `with_minimal_stake`, and `without_minimal_stake` allow \\\n to enumerate only the delegates that are active, inactive, have at \\\n least a minimal stake to participate in consensus and in governance, \\\n or do not have such a minimal stake, respectively. Note, setting \\\n these arguments to false has no effect.\"\n ~query:list_query\n ~output:(list Signature.Public_key_hash.encoding)\n raw_path\n\n let path = RPC_path.(raw_path /: Signature.Public_key_hash.rpc_arg)\n\n let info =\n RPC_service.get_service\n ~description:\"Everything about a delegate.\"\n ~query:RPC_query.empty\n ~output:info_encoding\n path\n\n let full_balance =\n RPC_service.get_service\n ~description:\n \"Returns the full balance (in mutez) of a given delegate, including \\\n the frozen deposits and the frozen bonds. It does not include its \\\n delegated balance.\"\n ~query:RPC_query.empty\n ~output:Tez.encoding\n RPC_path.(path / \"full_balance\")\n\n let current_frozen_deposits =\n RPC_service.get_service\n ~description:\n \"Returns the current amount of the frozen deposits (in mutez).\"\n ~query:RPC_query.empty\n ~output:Tez.encoding\n RPC_path.(path / \"current_frozen_deposits\")\n\n let frozen_deposits =\n RPC_service.get_service\n ~description:\n \"Returns the initial amount (that is, at the beginning of a cycle) of \\\n the frozen deposits (in mutez). This amount is the same as the \\\n current amount of the frozen deposits, unless the delegate has been \\\n punished.\"\n ~query:RPC_query.empty\n ~output:Tez.encoding\n RPC_path.(path / \"frozen_deposits\")\n\n let staking_balance =\n RPC_service.get_service\n ~description:\n \"Returns the total amount of tokens (in mutez) delegated to a given \\\n delegate. This includes the balances of all the contracts that \\\n delegate to it, but also the balance of the delegate itself, its \\\n frozen deposits, and its frozen bonds.\"\n ~query:RPC_query.empty\n ~output:Tez.encoding\n RPC_path.(path / \"staking_balance\")\n\n let frozen_deposits_limit =\n RPC_service.get_service\n ~description:\n \"Returns the frozen deposits limit for the given delegate or none if \\\n no limit is set.\"\n ~query:RPC_query.empty\n ~output:(Data_encoding.option Tez.encoding)\n RPC_path.(path / \"frozen_deposits_limit\")\n\n let delegated_contracts =\n RPC_service.get_service\n ~description:\n \"Returns the list of contracts that delegate to a given delegate.\"\n ~query:RPC_query.empty\n ~output:(list Contract.encoding)\n RPC_path.(path / \"delegated_contracts\")\n\n let delegated_balance =\n RPC_service.get_service\n ~description:\n \"Returns the sum (in mutez) of all balances of all the contracts that \\\n delegate to a given delegate. This excludes the delegate's own \\\n balance, its frozen deposits and its frozen bonds.\"\n ~query:RPC_query.empty\n ~output:Tez.encoding\n RPC_path.(path / \"delegated_balance\")\n\n let deactivated =\n RPC_service.get_service\n ~description:\n \"Tells whether the delegate is currently tagged as deactivated or not.\"\n ~query:RPC_query.empty\n ~output:bool\n RPC_path.(path / \"deactivated\")\n\n let grace_period =\n RPC_service.get_service\n ~description:\n \"Returns the cycle by the end of which the delegate might be \\\n deactivated if she fails to execute any delegate action. A \\\n deactivated delegate might be reactivated (without loosing any stake) \\\n by simply re-registering as a delegate. For deactivated delegates, \\\n this value contains the cycle at which they were deactivated.\"\n ~query:RPC_query.empty\n ~output:Cycle.encoding\n RPC_path.(path / \"grace_period\")\n\n let voting_power =\n RPC_service.get_service\n ~description:\"The voting power in the vote listings for a given delegate.\"\n ~query:RPC_query.empty\n ~output:Data_encoding.int64\n RPC_path.(path / \"voting_power\")\n\n let voting_info =\n RPC_service.get_service\n ~description:\n \"Returns the delegate info (e.g. voting power) found in the listings \\\n of the current voting period.\"\n ~query:RPC_query.empty\n ~output:Vote.delegate_info_encoding\n RPC_path.(path / \"voting_info\")\n\n let consensus_key =\n RPC_service.get_service\n ~description:\n \"The active consensus key for a given delegate and the pending \\\n consensus keys.\"\n ~query:RPC_query.empty\n ~output:\n Data_encoding.(\n obj2\n (req \"active\" Signature.Public_key_hash.encoding)\n (dft\n \"pendings\"\n (list\n (obj2\n (req \"cycle\" Cycle.encoding)\n (req \"pkh\" Signature.Public_key_hash.encoding)))\n []))\n RPC_path.(path / \"consensus_key\")\n\n let participation =\n RPC_service.get_service\n ~description:\n \"Returns cycle and level participation information. In particular this \\\n indicates, in the field 'expected_cycle_activity', the number of \\\n slots the delegate is expected to have in the cycle based on its \\\n active stake. The field 'minimal_cycle_activity' indicates the \\\n minimal endorsing slots in the cycle required to get endorsing \\\n rewards. It is computed based on 'expected_cycle_activity. The fields \\\n 'missed_slots' and 'missed_levels' indicate the number of missed \\\n endorsing slots and missed levels (for endorsing) in the cycle so \\\n far. 'missed_slots' indicates the number of missed endorsing slots in \\\n the cycle so far. The field 'remaining_allowed_missed_slots' \\\n indicates the remaining amount of endorsing slots that can be missed \\\n in the cycle before forfeiting the rewards. Finally, \\\n 'expected_endorsing_rewards' indicates the endorsing rewards that \\\n will be distributed at the end of the cycle if activity at that point \\\n will be greater than the minimal required; if the activity is already \\\n known to be below the required minimum, then the rewards are zero.\"\n ~query:RPC_query.empty\n ~output:participation_info_encoding\n RPC_path.(path / \"participation\")\nend\n\nlet check_delegate_registered ctxt pkh =\n Delegate.registered ctxt pkh >>= function\n | true -> return_unit\n | false -> tzfail (Not_registered pkh)\n\nlet register () =\n let open Services_registration in\n register0 ~chunked:true S.list_delegate (fun ctxt q () ->\n Delegate.list ctxt >>= fun delegates ->\n (match q with\n | {active = true; inactive = false; _} ->\n List.filter_es\n (fun pkh -> Delegate.deactivated ctxt pkh >|=? not)\n delegates\n | {active = false; inactive = true; _} ->\n List.filter_es (fun pkh -> Delegate.deactivated ctxt pkh) delegates\n | {active = false; inactive = false; _}\n (* This case is counter-intuitive, but it represents the default behavior, when no arguments are given *)\n | {active = true; inactive = true; _} ->\n return delegates)\n >>=? fun delegates ->\n let minimal_stake = Constants.minimal_stake ctxt in\n match q with\n | {with_minimal_stake = true; without_minimal_stake = false; _} ->\n List.filter_es\n (fun pkh ->\n Delegate.staking_balance ctxt pkh >|=? fun staking_balance ->\n Tez.(staking_balance >= minimal_stake))\n delegates\n | {with_minimal_stake = false; without_minimal_stake = true; _} ->\n List.filter_es\n (fun pkh ->\n Delegate.staking_balance ctxt pkh >|=? fun staking_balance ->\n Tez.(staking_balance < minimal_stake))\n delegates\n | {with_minimal_stake = true; without_minimal_stake = true; _}\n | {with_minimal_stake = false; without_minimal_stake = false; _} ->\n return delegates) ;\n register1 ~chunked:false S.info (fun ctxt pkh () () ->\n check_delegate_registered ctxt pkh >>=? fun () ->\n Delegate.full_balance ctxt pkh >>=? fun full_balance ->\n Delegate.frozen_deposits ctxt pkh >>=? fun frozen_deposits ->\n Delegate.staking_balance ctxt pkh >>=? fun staking_balance ->\n Delegate.frozen_deposits_limit ctxt pkh >>=? fun frozen_deposits_limit ->\n Delegate.delegated_contracts ctxt pkh >>= fun delegated_contracts ->\n Delegate.delegated_balance ctxt pkh >>=? fun delegated_balance ->\n Delegate.deactivated ctxt pkh >>=? fun deactivated ->\n Delegate.last_cycle_before_deactivation ctxt pkh >>=? fun grace_period ->\n Vote.get_delegate_info ctxt pkh >>=? fun voting_info ->\n Delegate.Consensus_key.active_pubkey ctxt pkh >>=? fun consensus_key ->\n Delegate.Consensus_key.pending_updates ctxt pkh >|=? fun pendings ->\n {\n full_balance;\n current_frozen_deposits = frozen_deposits.current_amount;\n frozen_deposits = frozen_deposits.initial_amount;\n staking_balance;\n frozen_deposits_limit;\n delegated_contracts;\n delegated_balance;\n deactivated;\n grace_period;\n voting_info;\n active_consensus_key = consensus_key.consensus_pkh;\n pending_consensus_keys = pendings;\n }) ;\n register1 ~chunked:false S.full_balance (fun ctxt pkh () () ->\n trace (Balance_rpc_non_delegate pkh) (check_delegate_registered ctxt pkh)\n >>=? fun () -> Delegate.full_balance ctxt pkh) ;\n register1 ~chunked:false S.current_frozen_deposits (fun ctxt pkh () () ->\n check_delegate_registered ctxt pkh >>=? fun () ->\n Delegate.frozen_deposits ctxt pkh >>=? fun deposits ->\n return deposits.current_amount) ;\n register1 ~chunked:false S.frozen_deposits (fun ctxt pkh () () ->\n check_delegate_registered ctxt pkh >>=? fun () ->\n Delegate.frozen_deposits ctxt pkh >>=? fun deposits ->\n return deposits.initial_amount) ;\n register1 ~chunked:false S.staking_balance (fun ctxt pkh () () ->\n check_delegate_registered ctxt pkh >>=? fun () ->\n Delegate.staking_balance ctxt pkh) ;\n register1 ~chunked:false S.frozen_deposits_limit (fun ctxt pkh () () ->\n check_delegate_registered ctxt pkh >>=? fun () ->\n Delegate.frozen_deposits_limit ctxt pkh) ;\n register1 ~chunked:true S.delegated_contracts (fun ctxt pkh () () ->\n check_delegate_registered ctxt pkh >>=? fun () ->\n Delegate.delegated_contracts ctxt pkh >|= ok) ;\n register1 ~chunked:false S.delegated_balance (fun ctxt pkh () () ->\n check_delegate_registered ctxt pkh >>=? fun () ->\n Delegate.delegated_balance ctxt pkh) ;\n register1 ~chunked:false S.deactivated (fun ctxt pkh () () ->\n check_delegate_registered ctxt pkh >>=? fun () ->\n Delegate.deactivated ctxt pkh) ;\n register1 ~chunked:false S.grace_period (fun ctxt pkh () () ->\n check_delegate_registered ctxt pkh >>=? fun () ->\n Delegate.last_cycle_before_deactivation ctxt pkh) ;\n register1 ~chunked:false S.voting_power (fun ctxt pkh () () ->\n check_delegate_registered ctxt pkh >>=? fun () ->\n Vote.get_voting_power_free ctxt pkh) ;\n register1 ~chunked:false S.voting_info (fun ctxt pkh () () ->\n check_delegate_registered ctxt pkh >>=? fun () ->\n Vote.get_delegate_info ctxt pkh) ;\n register1 ~chunked:false S.consensus_key (fun ctxt pkh () () ->\n Delegate.Consensus_key.active_pubkey ctxt pkh >>=? fun pk ->\n Delegate.Consensus_key.pending_updates ctxt pkh >>=? fun pendings ->\n return (pk.consensus_pkh, pendings)) ;\n register1 ~chunked:false S.participation (fun ctxt pkh () () ->\n check_delegate_registered ctxt pkh >>=? fun () ->\n Delegate.participation_info ctxt pkh)\n\nlet list ctxt block ?(active = true) ?(inactive = false)\n ?(with_minimal_stake = true) ?(without_minimal_stake = false) () =\n RPC_context.make_call0\n S.list_delegate\n ctxt\n block\n {active; inactive; with_minimal_stake; without_minimal_stake}\n ()\n\nlet info ctxt block pkh = RPC_context.make_call1 S.info ctxt block pkh () ()\n\nlet full_balance ctxt block pkh =\n RPC_context.make_call1 S.full_balance ctxt block pkh () ()\n\nlet current_frozen_deposits ctxt block pkh =\n RPC_context.make_call1 S.current_frozen_deposits ctxt block pkh () ()\n\nlet frozen_deposits ctxt block pkh =\n RPC_context.make_call1 S.frozen_deposits ctxt block pkh () ()\n\nlet staking_balance ctxt block pkh =\n RPC_context.make_call1 S.staking_balance ctxt block pkh () ()\n\nlet frozen_deposits_limit ctxt block pkh =\n RPC_context.make_call1 S.frozen_deposits_limit ctxt block pkh () ()\n\nlet delegated_contracts ctxt block pkh =\n RPC_context.make_call1 S.delegated_contracts ctxt block pkh () ()\n\nlet delegated_balance ctxt block pkh =\n RPC_context.make_call1 S.delegated_balance ctxt block pkh () ()\n\nlet deactivated ctxt block pkh =\n RPC_context.make_call1 S.deactivated ctxt block pkh () ()\n\nlet grace_period ctxt block pkh =\n RPC_context.make_call1 S.grace_period ctxt block pkh () ()\n\nlet voting_power ctxt block pkh =\n RPC_context.make_call1 S.voting_power ctxt block pkh () ()\n\nlet voting_info ctxt block pkh =\n RPC_context.make_call1 S.voting_info ctxt block pkh () ()\n\nlet consensus_key ctxt block pkh =\n RPC_context.make_call1 S.consensus_key ctxt block pkh () ()\n\nlet participation ctxt block pkh =\n RPC_context.make_call1 S.participation ctxt block pkh () ()\n" ;
} ;
{ name = "Voting_services" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This module provides RPC services that return voting-related information. *)\n\nopen Alpha_context\n\nval ballots : 'a #RPC_context.simple -> 'a -> Vote.ballots shell_tzresult Lwt.t\n\nval ballot_list :\n 'a #RPC_context.simple ->\n 'a ->\n (Signature.Public_key_hash.t * Vote.ballot) list shell_tzresult Lwt.t\n\nval current_period :\n 'a #RPC_context.simple -> 'a -> Voting_period.info shell_tzresult Lwt.t\n\nval successor_period :\n 'a #RPC_context.simple -> 'a -> Voting_period.info shell_tzresult Lwt.t\n\nval current_quorum :\n 'a #RPC_context.simple -> 'a -> Int32.t shell_tzresult Lwt.t\n\nval listings :\n 'a #RPC_context.simple ->\n 'a ->\n (Signature.Public_key_hash.t * int64) list shell_tzresult Lwt.t\n\nval proposals :\n 'a #RPC_context.simple ->\n 'a ->\n Int64.t Protocol_hash.Map.t shell_tzresult Lwt.t\n\nval current_proposal :\n 'a #RPC_context.simple -> 'a -> Protocol_hash.t option shell_tzresult Lwt.t\n\nval register : unit -> unit\n\nval total_voting_power :\n 'a #RPC_context.simple -> 'a -> Int64.t shell_tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\nmodule S = struct\n let path = RPC_path.(open_root / \"votes\")\n\n let ballots =\n RPC_service.get_service\n ~description:\"Sum of ballots casted so far during a voting period.\"\n ~query:RPC_query.empty\n ~output:Vote.ballots_encoding\n RPC_path.(path / \"ballots\")\n\n let ballot_list =\n RPC_service.get_service\n ~description:\"Ballots casted so far during a voting period.\"\n ~query:RPC_query.empty\n ~output:\n Data_encoding.(\n list\n (obj2\n (req \"pkh\" Signature.Public_key_hash.encoding)\n (req \"ballot\" Vote.ballot_encoding)))\n RPC_path.(path / \"ballot_list\")\n\n let current_period =\n RPC_service.get_service\n ~description:\n \"Returns the voting period (index, kind, starting position) and \\\n related information (position, remaining) of the interrogated block.\"\n ~query:RPC_query.empty\n ~output:Voting_period.info_encoding\n RPC_path.(path / \"current_period\")\n\n let successor_period =\n RPC_service.get_service\n ~description:\n \"Returns the voting period (index, kind, starting position) and \\\n related information (position, remaining) of the next block.Useful to \\\n craft operations that will be valid in the next block.\"\n ~query:RPC_query.empty\n ~output:Voting_period.info_encoding\n RPC_path.(path / \"successor_period\")\n\n let current_quorum =\n RPC_service.get_service\n ~description:\"Current expected quorum.\"\n ~query:RPC_query.empty\n ~output:Data_encoding.int32\n RPC_path.(path / \"current_quorum\")\n\n let listings =\n RPC_service.get_service\n ~description:\"List of delegates with their voting power.\"\n ~query:RPC_query.empty\n ~output:Vote.listings_encoding\n RPC_path.(path / \"listings\")\n\n let proposals =\n RPC_service.get_service\n ~description:\"List of proposals with number of supporters.\"\n ~query:RPC_query.empty\n ~output:(Protocol_hash.Map.encoding Data_encoding.int64)\n RPC_path.(path / \"proposals\")\n\n let current_proposal =\n RPC_service.get_service\n ~description:\"Current proposal under evaluation.\"\n ~query:RPC_query.empty\n ~output:(Data_encoding.option Protocol_hash.encoding)\n RPC_path.(path / \"current_proposal\")\n\n let total_voting_power =\n RPC_service.get_service\n ~description:\"Total voting power in the voting listings.\"\n ~query:RPC_query.empty\n ~output:Data_encoding.int64\n RPC_path.(path / \"total_voting_power\")\nend\n\nlet register () =\n let open Services_registration in\n register0 ~chunked:false S.ballots (fun ctxt () () -> Vote.get_ballots ctxt) ;\n register0 ~chunked:true S.ballot_list (fun ctxt () () ->\n Vote.get_ballot_list ctxt >|= ok) ;\n register0 ~chunked:false S.current_period (fun ctxt () () ->\n Voting_period.get_rpc_current_info ctxt) ;\n register0 ~chunked:false S.successor_period (fun ctxt () () ->\n Voting_period.get_rpc_succ_info ctxt) ;\n register0 ~chunked:false S.current_quorum (fun ctxt () () ->\n Vote.get_current_quorum ctxt) ;\n register0 ~chunked:true S.proposals (fun ctxt () () ->\n Vote.get_proposals ctxt) ;\n register0 ~chunked:true S.listings (fun ctxt () () ->\n Vote.get_listings ctxt >|= ok) ;\n register0 ~chunked:false S.current_proposal (fun ctxt () () ->\n Vote.find_current_proposal ctxt) ;\n register0 ~chunked:false S.total_voting_power (fun ctxt () () ->\n Vote.get_total_voting_power_free ctxt)\n\nlet ballots ctxt block = RPC_context.make_call0 S.ballots ctxt block () ()\n\nlet ballot_list ctxt block =\n RPC_context.make_call0 S.ballot_list ctxt block () ()\n\nlet current_period ctxt block =\n RPC_context.make_call0 S.current_period ctxt block () ()\n\nlet successor_period ctxt block =\n RPC_context.make_call0 S.successor_period ctxt block () ()\n\nlet current_quorum ctxt block =\n RPC_context.make_call0 S.current_quorum ctxt block () ()\n\nlet listings ctxt block = RPC_context.make_call0 S.listings ctxt block () ()\n\nlet proposals ctxt block = RPC_context.make_call0 S.proposals ctxt block () ()\n\nlet current_proposal ctxt block =\n RPC_context.make_call0 S.current_proposal ctxt block () ()\n\nlet total_voting_power ctxt block =\n RPC_context.make_call0 S.total_voting_power ctxt block () ()\n" ;
} ;
{ name = "Tx_rollup_services" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\nval state :\n 'a #RPC_context.simple ->\n 'a ->\n Tx_rollup.t ->\n Tx_rollup_state.t shell_tzresult Lwt.t\n\n(** Returns the inbox for a transaction rollup for a given rollup\n level.\n\n Returns [Not_found] if the transaction rollup exists, but does not\n have inbox at that level. Fails if the transaction rollup does not\n exist. *)\nval inbox :\n 'a #RPC_context.simple ->\n 'a ->\n Tx_rollup.t ->\n Tx_rollup_level.t ->\n Tx_rollup_inbox.t option shell_tzresult Lwt.t\n\nval commitment :\n 'a #RPC_context.simple ->\n 'a ->\n Tx_rollup.t ->\n Tx_rollup_level.t ->\n Tx_rollup_commitment.Submitted_commitment.t option shell_tzresult Lwt.t\n\nval register : unit -> unit\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2021 Marigold <contact@marigold.dev> *)\n(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\nopen Alpha_context\n\nlet custom_root =\n (RPC_path.(open_root / \"context\" / \"tx_rollup\")\n : RPC_context.t RPC_path.context)\n\nmodule S = struct\n let state =\n RPC_service.get_service\n ~description:\"Access the state of a rollup.\"\n ~query:RPC_query.empty\n ~output:Tx_rollup_state.encoding\n RPC_path.(custom_root /: Tx_rollup.rpc_arg / \"state\")\n\n let inbox =\n RPC_service.get_service\n ~description:\"Get the inbox of a transaction rollup\"\n ~query:RPC_query.empty\n ~output:Data_encoding.(option Tx_rollup_inbox.encoding)\n RPC_path.(\n custom_root /: Tx_rollup.rpc_arg / \"inbox\" /: Tx_rollup_level.rpc_arg)\n\n let commitment =\n RPC_service.get_service\n ~description:\"Return the commitment for a level, if any\"\n ~query:RPC_query.empty\n ~output:\n Data_encoding.(\n option Tx_rollup_commitment.Submitted_commitment.encoding)\n RPC_path.(\n custom_root /: Tx_rollup.rpc_arg / \"commitment\"\n /: Tx_rollup_level.rpc_arg)\n\n let pending_bonded_commitments =\n RPC_service.get_service\n ~description:\n \"Get the number of pending bonded commitments for a pkh on a rollup\"\n ~query:RPC_query.empty\n ~output:Data_encoding.int32\n RPC_path.(\n custom_root /: Tx_rollup.rpc_arg / \"pending_bonded_commitments\"\n /: Signature.Public_key_hash.rpc_arg)\nend\n\nlet register () =\n let open Services_registration in\n opt_register1 ~chunked:false S.state (fun ctxt tx_rollup () () ->\n Tx_rollup_state.find ctxt tx_rollup >|=? snd) ;\n register2 ~chunked:false S.inbox (fun ctxt tx_rollup level () () ->\n Tx_rollup_inbox.find ctxt level tx_rollup >|=? snd) ;\n register2 ~chunked:false S.commitment (fun ctxt tx_rollup level () () ->\n Tx_rollup_state.get ctxt tx_rollup >>=? fun (ctxt, state) ->\n Tx_rollup_commitment.find ctxt tx_rollup state level\n >|=? fun (_, commitment) -> commitment) ;\n register2\n ~chunked:false\n S.pending_bonded_commitments\n (fun ctxt tx_rollup pkh () () ->\n Tx_rollup_commitment.pending_bonded_commitments ctxt tx_rollup pkh\n >|=? fun (_, count) -> Int32.of_int count)\n\nlet state ctxt block tx_rollup =\n RPC_context.make_call1 S.state ctxt block tx_rollup () ()\n\nlet inbox ctxt block tx_rollup level =\n RPC_context.make_call2 S.inbox ctxt block tx_rollup level () ()\n\nlet commitment ctxt block tx_rollup level =\n RPC_context.make_call2 S.commitment ctxt block tx_rollup level () ()\n" ;
} ;
{ name = "Dal_services" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** [shards ctxt ~level] returns the DAL committee as an association\n list that associates to the public key hash [pkh] of the member of\n the committee an interval [(s,n)], meaning that the slots\n [s;s+1;...;s+n-1] belongs to [pkh]. It is guaranteed that [n>0]. *)\nval shards :\n Alpha_context.t ->\n level:Alpha_context.Raw_level.t ->\n (Signature.Public_key_hash.t * (int * int)) list tzresult Lwt.t\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\nlet assert_dal_feature_enabled ctxt =\n let open Constants in\n let Parametric.{dal = {feature_enable; _}; _} = parametric ctxt in\n error_unless\n Compare.Bool.(feature_enable = true)\n Dal_errors.Dal_feature_disabled\n\nlet shards ctxt ~level =\n let open Lwt_result_syntax in\n let open Dal.Attestation in\n assert_dal_feature_enabled ctxt >>?= fun () ->\n let level = Level.from_raw ctxt level in\n let pkh_from_tenderbake_slot slot =\n Stake_distribution.slot_owner ctxt level slot\n >|=? fun (ctxt, consensus_key) -> (ctxt, consensus_key.delegate)\n in\n (* We do not cache this committee. This function being used by RPCs\n to know the DAL committee at some particular level. *)\n let* committee =\n Dal.Attestation.compute_committee ctxt pkh_from_tenderbake_slot\n in\n Signature.Public_key_hash.Map.bindings committee.pkh_to_shards |> return\n" ;
} ;
{ name = "Alpha_services" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2019-2020 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** This declares Protocol RPC services.\n\n Protocol RPC services are read-only, and support querying the state of the\n ledger (including information such as existing contracts, delegation,\n voting, and so on), at a given block height.\n\n This is a mostly internal module used from [rpc_services] in [Main].\n *)\n\nopen Alpha_context\n\nmodule Seed_computation : sig\n val get :\n 'a #RPC_context.simple ->\n 'a ->\n Seed.seed_computation_status shell_tzresult Lwt.t\nend\n\nmodule Seed : sig\n val get : 'a #RPC_context.simple -> 'a -> Seed.seed shell_tzresult Lwt.t\nend\n\nmodule Nonce : sig\n type info = Revealed of Nonce.t | Missing of Nonce_hash.t | Forgotten\n\n val get :\n 'a #RPC_context.simple -> 'a -> Raw_level.t -> info shell_tzresult Lwt.t\nend\n\nmodule Snapshot_index : sig\n val get :\n 'a #RPC_context.simple ->\n 'a ->\n ?cycle:Cycle.t ->\n unit ->\n int shell_tzresult Lwt.t\nend\n\nmodule Contract = Contract_services\nmodule Constants = Constants_services\nmodule Delegate = Delegate_services\nmodule Voting = Voting_services\nmodule Sapling = Sapling_services\n\nmodule Liquidity_baking : sig\n val get_cpmm_address :\n 'a #RPC_context.simple -> 'a -> Contract_hash.t shell_tzresult Lwt.t\nend\n\nmodule Cache : sig\n val cached_contracts :\n 'a #RPC_context.simple ->\n 'a ->\n (Contract_hash.t * int) list shell_tzresult Lwt.t\n\n val contract_cache_size :\n 'a #RPC_context.simple -> 'a -> int shell_tzresult Lwt.t\n\n val contract_cache_size_limit :\n 'a #RPC_context.simple -> 'a -> int shell_tzresult Lwt.t\n\n val contract_rank :\n 'a #RPC_context.simple ->\n 'a ->\n Contract_hash.t ->\n int option shell_tzresult Lwt.t\nend\n\nval register : unit -> unit\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* Copyright (c) 2019-2020 Nomadic Labs <contact@nomadic-labs.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\nopen Alpha_context\n\nlet custom_root = RPC_path.open_root\n\nmodule Seed_computation = struct\n module S = struct\n let seed_computation_status_encoding =\n let open Seed in\n Data_encoding.(\n union\n [\n case\n (Tag 0)\n ~title:\"Nonce revelation stage\"\n (obj1 (req \"nonce_revelation_stage\" unit))\n (function Nonce_revelation_stage -> Some () | _ -> None)\n (fun () -> Nonce_revelation_stage);\n case\n (Tag 1)\n ~title:\"VDF revelation stage\"\n (obj2\n (req \"seed_discriminant\" Seed.seed_encoding)\n (req \"seed_challenge\" Seed.seed_encoding))\n (function\n | Vdf_revelation_stage {seed_discriminant; seed_challenge} ->\n Some (seed_discriminant, seed_challenge)\n | _ -> None)\n (fun (seed_discriminant, seed_challenge) ->\n Vdf_revelation_stage {seed_discriminant; seed_challenge});\n case\n (Tag 2)\n ~title:\"Computation finished\"\n (obj1 (req \"computation_finished\" unit))\n (function Computation_finished -> Some () | _ -> None)\n (fun () -> Computation_finished);\n ])\n\n let seed_computation =\n RPC_service.get_service\n ~description:\"Seed computation status\"\n ~query:RPC_query.empty\n ~output:seed_computation_status_encoding\n RPC_path.(custom_root / \"context\" / \"seed_computation\")\n end\n\n let () =\n let open Services_registration in\n register0 ~chunked:false S.seed_computation (fun ctxt () () ->\n Seed.get_seed_computation_status ctxt)\n\n let get ctxt block =\n RPC_context.make_call0 S.seed_computation ctxt block () ()\nend\n\nmodule Seed = struct\n module S = struct\n open Data_encoding\n\n let seed =\n RPC_service.post_service\n ~description:\"Seed of the cycle to which the block belongs.\"\n ~query:RPC_query.empty\n ~input:empty\n ~output:Seed.seed_encoding\n RPC_path.(custom_root / \"context\" / \"seed\")\n end\n\n let () =\n let open Services_registration in\n register0 ~chunked:false S.seed (fun ctxt () () ->\n let l = Level.current ctxt in\n Seed.for_cycle ctxt l.cycle)\n\n let get ctxt block = RPC_context.make_call0 S.seed ctxt block () ()\nend\n\nmodule Nonce = struct\n type info = Revealed of Nonce.t | Missing of Nonce_hash.t | Forgotten\n\n let info_encoding =\n let open Data_encoding in\n union\n [\n case\n (Tag 0)\n ~title:\"Revealed\"\n (obj1 (req \"nonce\" Nonce.encoding))\n (function Revealed nonce -> Some nonce | _ -> None)\n (fun nonce -> Revealed nonce);\n case\n (Tag 1)\n ~title:\"Missing\"\n (obj1 (req \"hash\" Nonce_hash.encoding))\n (function Missing nonce -> Some nonce | _ -> None)\n (fun nonce -> Missing nonce);\n case\n (Tag 2)\n ~title:\"Forgotten\"\n empty\n (function Forgotten -> Some () | _ -> None)\n (fun () -> Forgotten);\n ]\n\n module S = struct\n let get =\n RPC_service.get_service\n ~description:\"Info about the nonce of a previous block.\"\n ~query:RPC_query.empty\n ~output:info_encoding\n RPC_path.(custom_root / \"context\" / \"nonces\" /: Raw_level.rpc_arg)\n end\n\n let register () =\n let open Services_registration in\n register1 ~chunked:false S.get (fun ctxt raw_level () () ->\n let level = Level.from_raw ctxt raw_level in\n Nonce.get ctxt level >|= function\n | Ok (Revealed nonce) -> ok (Revealed nonce)\n | Ok (Unrevealed {nonce_hash; _}) -> ok (Missing nonce_hash)\n | Error _ -> ok Forgotten)\n\n let get ctxt block level = RPC_context.make_call1 S.get ctxt block level () ()\nend\n\ntype error += No_available_snapshots of {min_cycle : int32}\n\nlet () =\n Error_monad.register_error_kind\n `Permanent\n ~id:\"no_available_snapshots\"\n ~title:\"No available snapshots\"\n ~description:\"No available snapshots\"\n ~pp:(fun ppf min_cycle ->\n Format.fprintf ppf \"No available snapshots until cycle %ld\" min_cycle)\n Data_encoding.(obj1 (req \"min_cycle\" int32))\n (function\n | No_available_snapshots {min_cycle} -> Some min_cycle | _ -> None)\n (fun min_cycle -> No_available_snapshots {min_cycle})\n\nmodule Snapshot_index = struct\n module S = struct\n let cycle_query : Cycle.t option RPC_query.t =\n let open RPC_query in\n query (fun x -> x)\n |+ opt_field \"cycle\" Cycle.rpc_arg (fun cycle -> cycle)\n |> seal\n\n let selected_snapshot =\n RPC_service.get_service\n ~description:\n \"Returns the index of the selected snapshot for the current cycle or \\\n for the specific `cycle` passed as argument, if any.\"\n ~query:cycle_query\n ~output:Data_encoding.int31\n RPC_path.(custom_root / \"context\" / \"selected_snapshot\")\n end\n\n let register () =\n let open Services_registration in\n register0 ~chunked:false S.selected_snapshot (fun ctxt cycle () ->\n (* max_snapshot_index can be determined using constants only *)\n let blocks_per_stake_snapshot =\n Alpha_context.Constants.blocks_per_stake_snapshot ctxt\n in\n let blocks_per_cycle = Alpha_context.Constants.blocks_per_cycle ctxt in\n let preserved_cycles =\n Int32.of_int (Alpha_context.Constants.preserved_cycles ctxt)\n in\n let cycle =\n match cycle with\n | None -> Level.(current ctxt).cycle\n | Some cycle -> cycle\n in\n if Compare.Int32.(Cycle.to_int32 cycle <= Int32.succ preserved_cycles)\n then\n (* Early cycles are corner cases, fail if requested *)\n tzfail\n (No_available_snapshots {min_cycle = Int32.add preserved_cycles 2l})\n else\n let max_snapshot_index =\n Int32.div blocks_per_cycle blocks_per_stake_snapshot |> Int32.to_int\n in\n Alpha_context.Stake_distribution.compute_snapshot_index\n ctxt\n cycle\n ~max_snapshot_index)\n\n let get ctxt block ?cycle () =\n RPC_context.make_call0 S.selected_snapshot ctxt block cycle ()\nend\n\nmodule Contract = Contract_services\nmodule Constants = Constants_services\nmodule Delegate = Delegate_services\nmodule Voting = Voting_services\nmodule Sapling = Sapling_services\nmodule Tx_rollup = Tx_rollup_services\n\nmodule Liquidity_baking = struct\n module S = struct\n let get_cpmm_address =\n RPC_service.get_service\n ~description:\"Liquidity baking CPMM address\"\n ~query:RPC_query.empty\n ~output:Alpha_context.Contract.originated_encoding\n RPC_path.(custom_root / \"context\" / \"liquidity_baking\" / \"cpmm_address\")\n end\n\n let register () =\n let open Services_registration in\n register0 ~chunked:false S.get_cpmm_address (fun ctxt () () ->\n Alpha_context.Liquidity_baking.get_cpmm_address ctxt)\n\n let get_cpmm_address ctxt block =\n RPC_context.make_call0 S.get_cpmm_address ctxt block () ()\nend\n\nmodule Cache = struct\n module S = struct\n let cached_contracts =\n RPC_service.get_service\n ~description:\"Return the list of cached contracts\"\n ~query:RPC_query.empty\n ~output:Data_encoding.(list @@ tup2 Contract_hash.encoding int31)\n RPC_path.(custom_root / \"context\" / \"cache\" / \"contracts\" / \"all\")\n\n let contract_cache_size =\n RPC_service.get_service\n ~description:\"Return the size of the contract cache\"\n ~query:RPC_query.empty\n ~output:Data_encoding.int31\n RPC_path.(custom_root / \"context\" / \"cache\" / \"contracts\" / \"size\")\n\n let contract_cache_size_limit =\n RPC_service.get_service\n ~description:\"Return the size limit of the contract cache\"\n ~query:RPC_query.empty\n ~output:Data_encoding.int31\n RPC_path.(\n custom_root / \"context\" / \"cache\" / \"contracts\" / \"size_limit\")\n\n let contract_rank =\n RPC_service.post_service\n ~description:\n \"Return the number of cached contracts older than the provided \\\n contract\"\n ~query:RPC_query.empty\n ~input:Alpha_context.Contract.originated_encoding\n ~output:Data_encoding.(option int31)\n RPC_path.(custom_root / \"context\" / \"cache\" / \"contracts\" / \"rank\")\n end\n\n let register () =\n let open Services_registration in\n register0 ~chunked:true S.cached_contracts (fun ctxt () () ->\n Script_cache.entries ctxt |> Lwt.return) ;\n register0 ~chunked:false S.contract_cache_size (fun ctxt () () ->\n Script_cache.size ctxt |> return) ;\n register0 ~chunked:false S.contract_cache_size_limit (fun ctxt () () ->\n Script_cache.size_limit ctxt |> return) ;\n register0 ~chunked:false S.contract_rank (fun ctxt () contract ->\n Script_cache.contract_rank ctxt contract |> return)\n\n let cached_contracts ctxt block =\n RPC_context.make_call0 S.cached_contracts ctxt block () ()\n\n let contract_cache_size ctxt block =\n RPC_context.make_call0 S.contract_cache_size ctxt block () ()\n\n let contract_cache_size_limit ctxt block =\n RPC_context.make_call0 S.contract_cache_size_limit ctxt block () ()\n\n let contract_rank ctxt block contract =\n RPC_context.make_call0 S.contract_rank ctxt block () contract\nend\n\nlet register () =\n Contract.register () ;\n Constants.register () ;\n Delegate.register () ;\n Nonce.register () ;\n Snapshot_index.register () ;\n Voting.register () ;\n Sapling.register () ;\n Liquidity_baking.register () ;\n Cache.register () ;\n Tx_rollup.register ()\n" ;
} ;
{ name = "Main" ;
interface = Some "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(** Tezos Protocol Implementation - Protocol Signature Instance\n\n This module is the entrypoint to the protocol for shells and other\n embedders. This signature is an instance of\n {{!Tezos_protocol_environment_sigs.V7.T.Updater.PROTOCOL} the\n [Updater.PROTOCOL] signature} from the\n {{:https://tezos.gitlab.io/shell/the_big_picture.html#the-economic-protocol-environment-and-compiler}\n Protocol Environment}.\n\n Each Protocol depends on a version of the Protocol Environment. For the\n currently developed protocol, this is normally the latest version. You can\n see {{!Tezos_protocol_environment_sigs} the full list of versions here}.\n\n For details on how Protocol and Environment interact, see\n {{:https://tezos.gitlab.io/shell/the_big_picture.html} this overview}.\n *)\n\ntype operation_data = Alpha_context.packed_protocol_data\n\ntype operation = Alpha_context.packed_operation = {\n shell : Operation.shell_header;\n protocol_data : operation_data;\n}\n\ninclude\n Updater.PROTOCOL\n with type block_header_data = Alpha_context.Block_header.protocol_data\n and type block_header_metadata = Apply_results.block_metadata\n and type block_header = Alpha_context.Block_header.t\n and type operation_data := operation_data\n and type operation_receipt = Apply_results.packed_operation_metadata\n and type operation := operation\n and type validation_state = Validate.validation_state\n and type application_state = Apply.application_state\n" ;
implementation = "(*****************************************************************************)\n(* *)\n(* Open Source License *)\n(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)\n(* *)\n(* Permission is hereby granted, free of charge, to any person obtaining a *)\n(* copy of this software and associated documentation files (the \"Software\"),*)\n(* to deal in the Software without restriction, including without limitation *)\n(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)\n(* and/or sell copies of the Software, and to permit persons to whom the *)\n(* Software is furnished to do so, subject to the following conditions: *)\n(* *)\n(* The above copyright notice and this permission notice shall be included *)\n(* in all copies or substantial portions of the Software. *)\n(* *)\n(* THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)\n(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)\n(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)\n(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)\n(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)\n(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)\n(* DEALINGS IN THE SOFTWARE. *)\n(* *)\n(*****************************************************************************)\n\n(* Tezos Protocol Implementation - Protocol Signature Instance *)\n\ntype block_header_data = Alpha_context.Block_header.protocol_data\n\ntype block_header = Alpha_context.Block_header.t = {\n shell : Block_header.shell_header;\n protocol_data : block_header_data;\n}\n\nlet block_header_data_encoding =\n Alpha_context.Block_header.protocol_data_encoding\n\ntype block_header_metadata = Apply_results.block_metadata\n\nlet block_header_metadata_encoding = Apply_results.block_metadata_encoding\n\ntype operation_data = Alpha_context.packed_protocol_data =\n | Operation_data :\n 'kind Alpha_context.Operation.protocol_data\n -> operation_data\n\nlet operation_data_encoding = Alpha_context.Operation.protocol_data_encoding\n\ntype operation_receipt = Apply_results.packed_operation_metadata =\n | Operation_metadata :\n 'kind Apply_results.operation_metadata\n -> operation_receipt\n | No_operation_metadata : operation_receipt\n\nlet operation_receipt_encoding = Apply_results.operation_metadata_encoding\n\nlet operation_data_and_receipt_encoding =\n Apply_results.operation_data_and_metadata_encoding\n\ntype operation = Alpha_context.packed_operation = {\n shell : Operation.shell_header;\n protocol_data : operation_data;\n}\n\nlet acceptable_pass = Alpha_context.Operation.acceptable_pass\n\nlet max_block_length = Alpha_context.Block_header.max_header_length\n\nlet max_operation_data_length =\n Alpha_context.Constants.max_operation_data_length\n\nlet validation_passes =\n let open Alpha_context.Constants in\n Updater.\n [\n (* 2048 endorsements *)\n {max_size = 2048 * 2048; max_op = Some 2048};\n (* 32k of voting operations *)\n {max_size = 32 * 1024; max_op = None};\n (* revelations, wallet activations and denunciations *)\n {\n max_size = max_anon_ops_per_block * 1024;\n max_op = Some max_anon_ops_per_block;\n };\n (* 512kB *)\n {max_size = 512 * 1024; max_op = None};\n ]\n\nlet rpc_services =\n Alpha_services.register () ;\n Services_registration.get_rpc_services ()\n\ntype validation_state = Validate.validation_state\n\ntype application_state = Apply.application_state\n\nlet init_allowed_consensus_operations ctxt ~endorsement_level\n ~preendorsement_level =\n let open Lwt_result_syntax in\n let open Alpha_context in\n let* ctxt = Delegate.prepare_stake_distribution ctxt in\n let* ctxt, allowed_endorsements, allowed_preendorsements =\n if Level.(endorsement_level = preendorsement_level) then\n let* ctxt, slots =\n Baking.endorsing_rights_by_first_slot ctxt endorsement_level\n in\n let consensus_operations = slots in\n return (ctxt, consensus_operations, consensus_operations)\n else\n let* ctxt, endorsements =\n Baking.endorsing_rights_by_first_slot ctxt endorsement_level\n in\n let* ctxt, preendorsements =\n Baking.endorsing_rights_by_first_slot ctxt preendorsement_level\n in\n return (ctxt, endorsements, preendorsements)\n in\n let ctxt =\n Consensus.initialize_consensus_operation\n ctxt\n ~allowed_endorsements\n ~allowed_preendorsements\n in\n return ctxt\n\n(** Circumstances and relevant information for [begin_validation] and\n [begin_application] below. *)\ntype mode =\n | Application of block_header\n | Partial_validation of block_header\n | Construction of {\n predecessor_hash : Block_hash.t;\n timestamp : Time.t;\n block_header_data : block_header_data;\n }\n | Partial_construction of {\n predecessor_hash : Block_hash.t;\n timestamp : Time.t;\n }\n\nlet prepare_ctxt ctxt mode ~(predecessor : Block_header.shell_header) =\n let open Lwt_result_syntax in\n let open Alpha_context in\n let level, timestamp =\n match mode with\n | Application block_header | Partial_validation block_header ->\n (block_header.shell.level, block_header.shell.timestamp)\n | Construction {timestamp; _} | Partial_construction {timestamp; _} ->\n (Int32.succ predecessor.level, timestamp)\n in\n let* ctxt, migration_balance_updates, migration_operation_results =\n prepare ctxt ~level ~predecessor_timestamp:predecessor.timestamp ~timestamp\n in\n let*? predecessor_raw_level = Raw_level.of_int32 predecessor.level in\n let predecessor_level = Level.from_raw ctxt predecessor_raw_level in\n (* During block (full or partial) application or full construction,\n endorsements must be for [predecessor_level] and preendorsements,\n if any, for the block's level. In the mempool (partial\n construction), only consensus operations for [predecessor_level]\n (that is, head's level) are allowed (except for grandparent\n endorsements, which are handled differently). *)\n let preendorsement_level =\n match mode with\n | Application _ | Partial_validation _ | Construction _ ->\n Level.current ctxt\n | Partial_construction _ -> predecessor_level\n in\n let* ctxt =\n init_allowed_consensus_operations\n ctxt\n ~endorsement_level:predecessor_level\n ~preendorsement_level\n in\n Dal_apply.initialisation ~level:predecessor_level ctxt >>=? fun ctxt ->\n return\n ( ctxt,\n migration_balance_updates,\n migration_operation_results,\n predecessor_level,\n predecessor_raw_level )\n\nlet begin_validation ctxt chain_id mode ~predecessor =\n let open Lwt_result_syntax in\n let open Alpha_context in\n let* ( ctxt,\n _migration_balance_updates,\n _migration_operation_results,\n predecessor_level,\n _predecessor_raw_level ) =\n prepare_ctxt ctxt ~predecessor mode\n in\n let predecessor_timestamp = predecessor.timestamp in\n let predecessor_fitness = predecessor.fitness in\n match mode with\n | Application block_header ->\n let*? fitness = Fitness.from_raw block_header.shell.fitness in\n Validate.begin_application\n ctxt\n chain_id\n ~predecessor_level\n ~predecessor_timestamp\n block_header\n fitness\n | Partial_validation block_header ->\n let*? fitness = Fitness.from_raw block_header.shell.fitness in\n Validate.begin_partial_validation\n ctxt\n chain_id\n ~predecessor_level\n ~predecessor_timestamp\n block_header\n fitness\n | Construction {predecessor_hash; timestamp; block_header_data} ->\n let*? predecessor_round = Fitness.round_from_raw predecessor_fitness in\n let*? round =\n Round.round_of_timestamp\n (Constants.round_durations ctxt)\n ~predecessor_timestamp\n ~predecessor_round\n ~timestamp\n in\n Validate.begin_full_construction\n ctxt\n chain_id\n ~predecessor_level\n ~predecessor_round\n ~predecessor_timestamp\n ~predecessor_hash\n round\n block_header_data.contents\n | Partial_construction _ ->\n let*? predecessor_round = Fitness.round_from_raw predecessor_fitness in\n let*? grandparent_round =\n Fitness.predecessor_round_from_raw predecessor_fitness\n in\n return\n (Validate.begin_partial_construction\n ctxt\n chain_id\n ~predecessor_level\n ~predecessor_round\n ~grandparent_round)\n\nlet validate_operation = Validate.validate_operation\n\nlet finalize_validation = Validate.finalize_block\n\ntype error += Cannot_apply_in_partial_validation\n\nlet () =\n register_error_kind\n `Permanent\n ~id:\"main.begin_application.cannot_apply_in_partial_validation\"\n ~title:\"cannot_apply_in_partial_validation\"\n ~description:\n \"Cannot instantiate an application state using the 'Partial_validation' \\\n mode.\"\n ~pp:(fun ppf () ->\n Format.fprintf\n ppf\n \"Cannot instantiate an application state using the \\\n 'Partial_validation' mode.\")\n Data_encoding.(empty)\n (function Cannot_apply_in_partial_validation -> Some () | _ -> None)\n (fun () -> Cannot_apply_in_partial_validation)\n\nlet begin_application ctxt chain_id mode ~predecessor =\n let open Lwt_result_syntax in\n let open Alpha_context in\n let* ( ctxt,\n migration_balance_updates,\n migration_operation_results,\n predecessor_level,\n predecessor_raw_level ) =\n prepare_ctxt ctxt ~predecessor mode\n in\n let predecessor_timestamp = predecessor.timestamp in\n let predecessor_fitness = predecessor.fitness in\n match mode with\n | Application block_header ->\n Apply.begin_application\n ctxt\n chain_id\n ~migration_balance_updates\n ~migration_operation_results\n ~predecessor_fitness\n block_header\n | Partial_validation _ -> tzfail Cannot_apply_in_partial_validation\n | Construction {predecessor_hash; timestamp; block_header_data; _} ->\n let*? predecessor_round = Fitness.round_from_raw predecessor_fitness in\n Apply.begin_full_construction\n ctxt\n chain_id\n ~migration_balance_updates\n ~migration_operation_results\n ~predecessor_timestamp\n ~predecessor_level\n ~predecessor_round\n ~predecessor_hash\n ~timestamp\n block_header_data.contents\n | Partial_construction {predecessor_hash; _} ->\n Apply.begin_partial_construction\n ctxt\n chain_id\n ~migration_balance_updates\n ~migration_operation_results\n ~predecessor_level:predecessor_raw_level\n ~predecessor_hash\n ~predecessor_fitness\n\nlet apply_operation = Apply.apply_operation\n\nlet finalize_application = Apply.finalize_block\n\nlet compare_operations (oph1, op1) (oph2, op2) =\n Alpha_context.Operation.compare (oph1, op1) (oph2, op2)\n\nlet init chain_id ctxt block_header =\n let level = block_header.Block_header.level in\n let timestamp = block_header.timestamp in\n let predecessor = block_header.predecessor in\n let typecheck (ctxt : Alpha_context.context) (script : Alpha_context.Script.t)\n =\n let allow_forged_in_storage =\n false\n (* There should be no forged value in bootstrap contracts. *)\n in\n Script_ir_translator.parse_script\n ctxt\n ~elab_conf:Script_ir_translator_config.(make ~legacy:true ())\n ~allow_forged_in_storage\n script\n >>=? fun (Ex_script (Script parsed_script), ctxt) ->\n Script_ir_translator.extract_lazy_storage_diff\n ctxt\n Optimized\n parsed_script.storage_type\n parsed_script.storage\n ~to_duplicate:Script_ir_translator.no_lazy_storage_id\n ~to_update:Script_ir_translator.no_lazy_storage_id\n ~temporary:false\n >>=? fun (storage, lazy_storage_diff, ctxt) ->\n Script_ir_translator.unparse_data\n ctxt\n Optimized\n parsed_script.storage_type\n storage\n >|=? fun (storage, ctxt) ->\n let storage = Alpha_context.Script.lazy_expr storage in\n (({script with storage}, lazy_storage_diff), ctxt)\n in\n (* The cache must be synced at the end of block validation, so we do\n so here for the first block in a protocol where `finalize_block`\n is not called. *)\n Alpha_context.Raw_level.of_int32 level >>?= fun raw_level ->\n let init_fitness =\n Alpha_context.Fitness.create_without_locked_round\n ~level:raw_level\n ~round:Alpha_context.Round.zero\n ~predecessor_round:Alpha_context.Round.zero\n in\n Alpha_context.prepare_first_block\n chain_id\n ~typecheck\n ~level\n ~timestamp\n ~predecessor\n ctxt\n >>=? fun ctxt ->\n let cache_nonce =\n Alpha_context.Cache.cache_nonce_from_block_header\n block_header\n ({\n payload_hash = Block_payload_hash.zero;\n payload_round = Alpha_context.Round.zero;\n liquidity_baking_toggle_vote = Alpha_context.Liquidity_baking.LB_pass;\n seed_nonce_hash = None;\n proof_of_work_nonce =\n Bytes.make Constants_repr.proof_of_work_nonce_size '0';\n }\n : Alpha_context.Block_header.contents)\n in\n Alpha_context.Cache.Admin.sync ctxt cache_nonce >>= fun ctxt ->\n return\n (Alpha_context.finalize ctxt (Alpha_context.Fitness.to_raw init_fitness))\n\nlet value_of_key ~chain_id:_ ~predecessor_context:ctxt ~predecessor_timestamp\n ~predecessor_level:pred_level ~predecessor_fitness:_ ~predecessor:_\n ~timestamp =\n let level = Int32.succ pred_level in\n Alpha_context.prepare ctxt ~level ~predecessor_timestamp ~timestamp\n >>=? fun (ctxt, _, _) -> return (Apply.value_of_key ctxt)\n\nmodule Mempool = struct\n include Mempool_validation\n\n let init ctxt chain_id ~head_hash ~(head : Block_header.shell_header) =\n let open Lwt_result_syntax in\n let open Alpha_context in\n let* ( ctxt,\n _migration_balance_updates,\n _migration_operation_results,\n head_level,\n _head_raw_level ) =\n (* We use Partial_construction to factorize the [prepare_ctxt]. *)\n prepare_ctxt\n ctxt\n (Partial_construction\n {predecessor_hash = head_hash; timestamp = head.timestamp})\n ~predecessor:head\n in\n let*? predecessor_round = Fitness.round_from_raw head.fitness in\n let*? grandparent_round = Fitness.predecessor_round_from_raw head.fitness in\n return\n (init\n ctxt\n chain_id\n ~predecessor_level:head_level\n ~predecessor_round\n ~predecessor_hash:head_hash\n ~grandparent_round)\nend\n\n(* Vanity nonce: 7019123279060222 *)\n" ;
}] ;
}
end
module Registered =
Tezos_protocol_updater.Registered_protocol.Register_embedded_V8
(Tezos_protocol_016_PtMumbai.Environment)
(Tezos_protocol_016_PtMumbai.Protocol.Main)
(Source)